ADA Programming Guide

home *** CD-ROM | disk | FTP | other *** search

/ ADA Programming Guide / ADA Programming Guide.iso / adatutor / csparts / cspartb1.src < prev next >

Wrap

Text File | 1996-01-30 | 172KB | 4,535 lines

--:::::::::: --types.bdy --:::::::::: -- *************************************************** -- * * -- * CS_Parts_Types * BODY -- * * -- *************************************************** with Unchecked_Conversion; package body CS_Parts_Types is --| Notes (none) function To_Character is new Unchecked_Conversion (Source => BYTE, Target => CHARACTER); function From_Character is new Unchecked_Conversion (Source => CHARACTER, Target => BYTE); -- ................................................... -- . . -- . CS_Parts_Types.Convert . BODY -- . . -- ................................................... function Convert (Item : in CHARACTER) return BYTE is --| Notes (none) begin return From_Character (Item); end Convert; -- ................................................... -- . . -- . CS_Parts_Types.Convert . BODY -- . . -- ................................................... function Convert (Item : in INTEGER) return BYTE is --| Notes (none) I1 : INTEGER := Item; I2 : INTEGER := 0; begin for I in 1..8 loop I2 := (I2 * 2) + (I1 - (I1 / 2 * 2)); I1 := I1/2; end loop; return BYTE(I2); end Convert; -- ................................................... -- . . -- . CS_Parts_Types.Convert . BODY -- . . -- ................................................... function Convert (Item : in BYTE) return CHARACTER is --| Notes (none) CH : CHARACTER; begin if Item > 127 then CH := To_Character (Item - (Item / 128 * 128)); else CH := To_Character (Item); end if; return CH; end Convert; -- ................................................... -- . . -- . CS_Parts_Types.Convert . SPEC -- . . -- ................................................... function Convert (Item : in BYTE) return INTEGER is --| Notes (none) begin return INTEGER(Item); end Convert; end CS_Parts_Types; --:::::::::: --console.bdy --:::::::::: -- ********************************************************* -- * * -- * Console * BODY -- * * -- ********************************************************* with Text_IO; with Unchecked_Conversion; package body Console is --| Notes (none) type STATE is (DISABLED, ENABLED); Output_State : array (1..Max_Number_of_States) of STATE := (others => ENABLED); Current_State : NATURAL := 1; Terminal : TERMINAL_KIND := TTY; package INTIO is new TEXT_IO.INTEGER_IO(INTEGER); package FLTIO is new TEXT_IO.FLOAT_IO(FLOAT); function Rend_to_Int is new Unchecked_Conversion (RENDITION, INTEGER); -- ................................................................. -- . . -- . Console.Set_Terminal . BODY -- . . -- ................................................................. procedure Set_Terminal (New_Setting : in TERMINAL_KIND := TTY) is --| Notes (none) begin Terminal := New_Setting; end Set_Terminal; -- ................................................................. -- . . -- . Console.Enable_Output . BODY -- . . -- ................................................................. procedure Enable_Output is --| Notes (none) begin Output_State(Current_State) := ENABLED; end Enable_Output; -- ................................................................. -- . . -- . Console.Disable_Output . BODY -- . . -- ................................................................. procedure Disable_Output is --| Notes (none) begin Output_State(Current_State) := DISABLED; end Disable_Output; -- ................................................................. -- . . -- . Console.Push . BODY -- . . -- ................................................................. procedure Push is --| Notes (none) begin if Current_State = Max_Number_of_States then raise STATE_OVERFLOW; else Current_State := Current_State + 1; end if; end Push; -- ................................................................. -- . . -- . Console.Pop . BODY -- . . -- ................................................................. procedure Pop is --| Notes (none) begin if Current_State = Output_State'FIRST then raise STATE_UNDERFLOW; else Current_State := Current_State - 1; end if; end Pop; -- ................................................................. -- . . -- . Console.Position_Cursor . BODY -- . . -- ................................................................. procedure Position_Cursor (Row : in ROW_NUMBER; Column : in COLUMN_NUMBER) is --| Notes (none) begin if (Terminal /= TTY) and (Output_State(Current_State) = ENABLED) then Text_IO.Put (ASCII.ESC & "["); INTIO.Put (INTEGER(Row), 0); Text_IO.Put (';'); INTIO.Put (INTEGER(Column), 0); Text_IO.Put ('H'); end if; end Position_Cursor; -- ................................................................. -- . . -- . Console.Erase_Display . BODY -- . . -- ................................................................. procedure Erase_Display is --| Notes (none) begin if (Terminal /= TTY) and (Output_State(Current_State) = ENABLED) then Text_IO.Put (ASCII.ESC & "[2J"); end if; end Erase_Display; -- ................................................................. -- . . -- . Console.Erase_Line . BODY -- . . -- ................................................................. procedure Erase_Line is --| Notes (none) begin if (Terminal /= TTY) and (Output_State(Current_State) = ENABLED) then Text_IO.Put (ASCII.ESC & "[K"); end if; end Erase_Line; -- ................................................................. -- . . -- . Console.Set_Rendition . BODY -- . . -- ................................................................. procedure Set_Rendition (New_Setting : in RENDITION) is --| Notes --| If the value of Terminal is VT100, no action is taken for any --| of the color renditions. begin if Output_State(Current_State) = ENABLED then case New_Setting is when ALL_ATTRIBUTES_OFF => if Terminal = ANSI then Text_IO.Put (ASCII.ESC & "[0m"); elsif Terminal = VT100 then Text_IO.Put (ASCII.ESC & "[m"); end if; when HIGH_INTENSITY | BLINKING | REVERSE_VIDEO => if Terminal /= TTY then Text_IO.Put (ASCII.ESC & "["); INTIO.Put (Rend_to_Int(New_Setting), 0); Text_IO.Put ('m'); end if; when others => if Terminal = ANSI then Text_IO.Put (ASCII.ESC & "["); INTIO.Put (Rend_to_Int(New_Setting), 0); Text_IO.Put ('m'); end if; end case; end if; end Set_Rendition; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put (Item : in CHARACTER) is --| Notes (none) begin if Output_State(Current_State) = ENABLED then Text_IO.Put (Item); end if; end Put; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put (Item : in STRING) is --| Notes (none) begin if Output_State(Current_State) = ENABLED then Text_IO.Put (Item); end if; end Put; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put ( Item : in STRING; Field_Width : in NATURAL; On_Overflow : in OVERFLOW_ACTION := TRUNCATE_TAIL; On_Underflow : in JUSTIFICATION := LEFT_JUSTIFIED; Fill_Char : in CHARACTER := ' '; Overflow_Char : in CHARACTER := '*' ) is --| Notes (none) First_Char : NATURAL := Item'first; Last_Char : NATURAL := Item'last; Fill_Width : NATURAL; begin if Output_State(Current_State) = ENABLED then if Item'length > Field_Width then case On_Overflow is when TRUNCATE_TAIL => Last_Char := First_Char + Field_Width - 1; Text_IO.Put (Item(First_Char .. Last_Char)); when TRUNCATE_HEAD => First_Char := Last_Char - Field_Width + 1; Text_IO.Put (Item(First_Char .. Last_Char)); when FILL_WITH_OVERFLOW_CHAR => for I in 1 .. Field_Width loop Text_IO.Put (Overflow_Char); end loop; end case; elsif Item'length < Field_Width then Fill_Width := Field_Width - Item'length; case On_Underflow is when LEFT_JUSTIFIED => Text_IO.Put (Item); for I in 1 .. Fill_Width loop Text_IO.Put (Fill_Char); end loop; when RIGHT_JUSTIFIED => for I in 1 .. Fill_Width loop Text_IO.Put (Fill_Char); end loop; Text_IO.Put (Item); end case; else Text_IO.Put (Item); end if; end if; end Put; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put (Item : in INTEGER; Width : in NATURAL; On_Overflow : in NUMERIC_OVERFLOW_ACTION := FILL_WITH_OVERFLOW_CHAR; Overflow_Char : in CHARACTER := '*') is --| Notes (none) Overflow : BOOLEAN := FALSE; begin if Output_State(Current_State) = ENABLED then begin if Width = 0 then Overflow := TRUE; else if Item < 0 then if Item <= -10**(Width-1) then Overflow := TRUE; end if; else if Item >= 10**Width then Overflow := TRUE; end if; end if; end if; exception when others => Overflow := FALSE; end; if not Overflow then INTIO.Put (Item, Width); else -- Overflow case On_Overflow is when FILL_WITH_OVERFLOW_CHAR => for I in 1 .. Width loop Text_IO.Put (Overflow_Char); end loop; when OUTPUT_FULL_NUMBER => INTIO.Put (Item, Width); end case; end if; end if; end Put; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put (Item : in FLOAT; Fore : in NATURAL; Aft : in NATURAL; On_Overflow : in NUMERIC_OVERFLOW_ACTION := FILL_WITH_OVERFLOW_CHAR; Overflow_Char : in CHARACTER := '*') is --| Notes (none) Overflow : BOOLEAN := FALSE; begin if Output_State(Current_State) = ENABLED then begin if Fore = 0 then Overflow := TRUE; else if Item < 0.0 then if Item <= -10.0**(Fore-1) then Overflow := TRUE; end if; else if Item >= 10.0**Fore then Overflow := TRUE; end if; end if; end if; exception when others => Overflow := FALSE; end; if not Overflow then FLTIO.Put (Item, Fore, Aft, 0); else -- Overflow case On_Overflow is when FILL_WITH_OVERFLOW_CHAR => for I in 1 .. Fore loop Text_IO.Put (Overflow_Char); end loop; Text_IO.Put (Overflow_Char); -- decimal for I in 1 .. Aft loop Text_IO.Put (Overflow_Char); end loop; when OUTPUT_FULL_NUMBER => FLTIO.Put (Item, Fore, Aft, 0); end case; end if; end if; end Put; -- ................................................................. -- . . -- . Console.Put . BODY -- . . -- ................................................................. procedure Put (Item : in FLOAT; Fore : in NATURAL := 2; Aft : in NATURAL := 2; Exp : in NATURAL := 3) is --| Notes (none) begin if Output_State(Current_State) = ENABLED then FLTIO.Put (Item, Fore, Aft, Exp); end if; end Put; -- ................................................................. -- . . -- . Console.Put_Line . BODY -- . . -- ................................................................. procedure Put_Line (Item : in STRING) is --| Notes (none) begin if Output_State(Current_State) = ENABLED then Text_IO.Put_Line (Item); end if; end Put_Line; -- ................................................................. -- . . -- . Console.New_Line . BODY -- . . -- ................................................................. procedure New_Line is --| Notes (none) begin if Output_State(Current_State) = ENABLED then Text_IO.New_Line; end if; end New_Line; -- ................................................................. -- . . -- . Console.Get . BODY -- . . -- ................................................................. procedure Get ( Item : out CHARACTER ) is --| Notes (none) begin -- Get Text_IO.Get (Item); exception when others => raise INPUT_ERROR; end Get; -- ................................................................. -- . . -- . Console.Get . BODY -- . . -- ................................................................. procedure Get ( Item : out INTEGER ) is --| Notes (none) begin -- Get INTIO.Get (Item); exception when others => raise INPUT_ERROR; end Get; -- ................................................................. -- . . -- . Console.Get . BODY -- . . -- ................................................................. procedure Get ( Item : out FLOAT ) is --| Notes (none) begin -- Get FLTIO.Get (Item); exception when others => raise INPUT_ERROR; end Get; -- ................................................................. -- . . -- . Console.Get_Line . BODY -- . . -- ................................................................. procedure Get_Line ( Item : out STRING; Last : out NATURAL ) is --| Notes (none) begin -- Get_Line Text_IO.Get_Line(Item, Last); end Get_Line; end Console; --:::::::::: --bintree.bdy --:::::::::: with unchecked_deallocation; Package body Binary_Trees_Pkg is --| Efficient implementation of binary trees. ---------------------------------------------------------------------------- -- Local Operations -- ---------------------------------------------------------------------------- procedure Free_Node is new unchecked_deallocation(Node, Node_Ptr); procedure Free_Tree is new unchecked_deallocation(Tree_Header, Tree); procedure Free_Iterator is new unchecked_deallocation(Iterator_Record, Iterator); ---------------------------------------------------------------------------- -- Visible Operations -- ---------------------------------------------------------------------------- Function Create --| Return an empty tree. return Tree is begin return new Tree_Header'(0, Null); end Create; ---------------------------------------------------------------------------- Procedure Insert_Node( V: Value_Type; N: in out Node_Ptr; Found: out boolean; Duplicate: out Value_Type ) is D: integer; begin Found := False; if N = null then N := new Node'(V, Null, Null); else D := Difference(V, N.Value); if D < 0 then Insert_Node(V, N.Less, Found, Duplicate); elsif D > 0 then Insert_Node(V, N.More, Found, Duplicate); else Found := True; Duplicate := N.Value; end if; end if; end Insert_Node; Procedure Replace_Node( V: Value_Type; N: in out Node_Ptr; Found: out boolean; Duplicate: out Value_Type ) is D: integer; begin Found := False; if N = null then N := new Node'(V, Null, Null); else D := Difference(V, N.Value); if D < 0 then Replace_Node(V, N.Less, Found, Duplicate); elsif D > 0 then Replace_Node(V, N.More, Found, Duplicate); else Found := True; Duplicate := N.Value; N.Value := V; end if; end if; end Replace_Node; Procedure Insert( --| Insert a value into a tree. V: Value_Type; --| Value to be inserted T: Tree --| Tree to contain the new value ) --| Raises: Duplicate_Value, Invalid_Tree. is Found: boolean; Duplicate: Value_Type; begin if T = null then raise Invalid_Tree; end if; Insert_Node(V, T.Root, Found, Duplicate); if Found then raise Duplicate_Value; end if; T.Count := T.Count + 1; end Insert; Procedure Insert_if_not_Found( --| Insert a value into a tree, provided a duplicate value is not already there V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; Duplicate: out Value_Type ) --| Raises: Invalid_Tree. is was_Found: boolean; begin if T = null then raise Invalid_Tree; end if; Insert_Node(V, T.Root, was_Found, Duplicate); Found := was_Found; if not was_Found then T.Count := T.Count + 1; end if; end Insert_if_Not_Found; procedure Replace_if_Found( --| Replace a value if label exists, otherwise insert it. V: Value_Type; --| Value to be inserted T: Tree; --| Tree to contain the new value Found: out boolean; --| Becomes True iff L already in tree Old_Value: out Value_Type --| the duplicate value, if there is one ) --| Raises: Invalid_Tree. is was_Found: boolean; Duplicate: Value_Type; begin if T = null then raise Invalid_Tree; end if; Replace_Node(V, T.Root, was_Found, Duplicate); Found := was_Found; if was_Found then Old_Value := Duplicate; else T.Count := T.Count + 1; end if; end Replace_if_Found; ---------------------------------------------------------------------------- procedure Destroy_Nodes( N: in out Node_Ptr ) is begin if N /= null then Destroy_Nodes(N.Less); Destroy_Nodes(N.More); Free_Node(N); end if; end Destroy_Nodes; procedure Destroy( --| Free space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ) is begin if T /= Null then Destroy_Nodes(T.Root); Free_Tree(T); end if; end Destroy; ---------------------------------------------------------------------------- procedure Destroy_Deep( --| Free all space allocated to a tree. T: in out Tree --| The tree to be reclaimed. ) is procedure Destroy_Nodes( N: in out node_Ptr ) is begin if N /= null then Free_Value(N.Value); Destroy_Nodes(N.Less); Destroy_Nodes(N.More); Free_Node(N); end if; end Destroy_Nodes; begin if T /= Null then Destroy_Nodes(T.Root); Free_Tree(T); end if; end Destroy_Deep; ---------------------------------------------------------------------------- Function Balanced_Tree( Count: natural ) return Tree is new_Tree: Tree := Create; procedure subtree(Count: natural; N: in out Node_Ptr) is new_Node: Node_Ptr; begin if Count = 1 then new_Node := new Node'(next_Value, Null, Null); elsif Count > 1 then new_node := new Node; subtree(Count/2, new_Node.Less); -- Half are less new_Node.Value := next_Value; -- Median value subtree(Count - Count/2 - 1, new_Node.More); -- Other half are more end if; N := new_Node; end subtree; begin new_Tree.Count := Count; subtree(Count, new_Tree.Root); return new_Tree; end Balanced_Tree; ---------------------------------------------------------------------------- Function Copy_Tree( T: Tree ) return Tree is I: Iterator; function next_Val return Value_type is V: Value_Type; begin Next(I, V); return copy_Value(V); end next_Val; function copy_Balanced is new Balanced_Tree(next_Val); begin I := Make_Iter(T); -- Will raise Invalid_Tree if necessary return copy_Balanced(Size(T)); end Copy_Tree; ---------------------------------------------------------------------------- Function Is_Empty( --| Check for an empty tree. T: Tree ) return boolean is begin return T = Null or else T.Root = Null; end Is_Empty; ---------------------------------------------------------------------------- procedure Find_Node( V: Value_Type; --| Value to be located N: Node_Ptr; --| subtree to be searched Match: out Value_Type; --| Matching value found in the tree Found: out Boolean --| TRUE iff a match was found ) is D: integer; begin if N = null then Found := False; return; end if; D := Difference(V, N.Value); if D < 0 then Find_Node(V, N.Less, Match, Found); elsif D > 0 then Find_Node(V, N.More, Match, Found); else Match := N.Value; Found := TRUE; end if; end Find_Node; Function Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Value_Type --| Raises: Not_Found. is Found: Boolean; Match: Value_Type; begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); if Found then return Match; else raise Not_Found; end if; end Find; Procedure Find( --| Search a tree for a value. V: Value_Type; --| Value to be located T: Tree; --| Tree to be searched Found: out Boolean; --| TRUE iff a match was found Match: out Value_Type --| Matching value found in the tree ) is begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); end Find; ---------------------------------------------------------------------------- function is_Found( --| Check a tree for a value. V: Value_Type; --| Value to be located T: Tree --| Tree to be searched ) return Boolean is Found: Boolean; Match: Value_Type; begin if T = Null then raise Invalid_Tree; end if; Find_Node(V, T.Root, Match, Found); return Found; end is_Found; ---------------------------------------------------------------------------- function Size( --| Return the count of values in T. T: Tree --| a tree ) return natural is begin if T = Null then Return 0; else Return T.Count; end if; end Size; ---------------------------------------------------------------------------- procedure Visit( T: Tree; Order: Scan_Kind ) is procedure visit_Inorder(N: Node_Ptr) is begin if N.Less /= null then visit_Inorder(N.Less); end if; Process(N.Value); if N.More /= null then visit_Inorder(N.More); end if; end visit_Inorder; procedure visit_preorder(N: Node_Ptr) is begin Process(N.Value); if N.Less /= null then visit_preorder(N.Less); end if; if N.More /= null then visit_preorder(N.More); end if; end visit_preorder; procedure visit_postorder(N: Node_Ptr) is begin if N.Less /= null then visit_postorder(N.Less); end if; if N.More /= null then visit_postorder(N.More); end if; Process(N.Value); end visit_postorder; begin if T = Null then raise Invalid_Tree; else case Order is when inorder => Visit_Inorder(T.Root); when preorder => Visit_preorder(T.Root); when postorder => Visit_postorder(T.Root); end case; end if; end Visit; ---------------------------------------------------------------------------- function subtree_Iter( --| Create an iterator over a subtree N: Node_Ptr; P: Iterator ) return Iterator is begin if N = Null then return new Iterator_Record'(State => Done, Parent => P, subtree => N); elsif N.Less = Null then return new Iterator_Record'(State => Middle, Parent => P, subtree => N); else return new Iterator_Record'(State => Left, Parent => P, subtree => N); end if; end subtree_Iter; function Make_Iter( --| Create an iterator over a tree T: Tree ) return Iterator is begin if T = Null then raise Invalid_Tree; end if; return subtree_Iter(T.Root, Null); end Make_Iter; ---------------------------------------------------------------------------- function More( --| Test for exhausted iterator I: Iterator --| The iterator to be tested ) return boolean is begin if I = Null then return False; elsif I.Parent = Null then return I.State /= Done and I.subtree /= Null; elsif I.State = Done then return More(I.Parent); else return True; end if; end More; ---------------------------------------------------------------------------- procedure pop_Iterator( I: in out Iterator ) is NI: Iterator; begin loop NI := I; I := I.Parent; Free_Iterator(NI); exit when I = Null; exit when I.State /= Done; end loop; end pop_Iterator; procedure Next( --| Scan the next value in I I: in out Iterator; --| an active iterator V: out Value_Type --| Next value scanned ) --| Raises: No_More. is NI: Iterator; begin if I = Null or I.State = Done then raise No_More; end if; case I.State is when Left => -- Return the leftmost value while I.subtree.Less /= Null loop -- Find leftmost subtree I.State := Middle; -- Middle is next at this level I := subtree_Iter(I.subtree.Less, I); end loop; V := I.subtree.Value; if I.subtree.More /= Null then -- There will be more... I.State := Right; -- ... coming from the right else -- Nothing else here pop_Iterator(I); -- Pop up to parent iterator end if; when Middle => V := I.subtree.Value; if I.subtree.More /= Null then -- There will be more... I.State := Right; -- ... coming from the right else -- Nothing else here so... pop_Iterator(I); -- ... Pop up to parent iterator end if; when Right => -- Return the value on the right I.State := Done; -- No more at this level I := subtree_Iter(I.subtree.More, I); Next(I, V); when Done => pop_Iterator(I); Next(I, V); end case; end Next; ---------------------------------------------------------------------------- end binary_trees_pkg; --:::::::::: --bit.bdy --:::::::::: package body BIT_FUNCTIONS is -- -- Implementation notes: -- this package uses integer arithmetic (mult by 2 and divide by 2) -- to accomplish most of the work involved. -- -- The ideal implementation would be similar to the following: -- -- OBJECT : INTEGER; -- type BIT_WORD is array (1..16) of BOOLEAN; -- pragma PACK (BIT_WORD) -- BIT_OBJECT : BIT_WORD; -- for BIT_OBJECT use at OBJECT'ADDRESS; -- -- This effectively defined BIT_OBJECT as a bit array, physically -- located at the same memory location as OBJECT. As a bit array, -- slices and boolean operations can be used! Unfortunately, -- the DG/Rolm ADE software does not support the address rep spec. -- -- WORD_SIZE : constant := 16; -- ASSUME 16 BIT WORDS! function BIT_EXTRACT (ITEM, START_AT, NBITS : INTEGER) return INTEGER is TEMP : INTEGER; BIT_VALUE : INTEGER; RESULT : INTEGER; begin TEMP := SHIFT_RIGHT (ITEM, START_AT); BIT_VALUE := (TEMP mod 2 ** NBITS); if BIT_VALUE <= INTEGER'LAST then RESULT := BIT_VALUE; else RESULT := BIT_VALUE - INTEGER'LAST; end if; return RESULT; end BIT_EXTRACT; function UBIT_EXTRACT (ITEM, START_AT, NBITS : INTEGER) return INTEGER is TEMP : INTEGER; begin TEMP := SHIFT_RIGHT (ITEM, START_AT); return TEMP mod (2 ** NBITS); end UBIT_EXTRACT; function BIT_INSERT (THIS_ITEM, NBITS, INTO_ITEM, START_AT : INTEGER) return INTEGER is ITEM : INTEGER; begin ITEM := THIS_ITEM mod (2 ** NBITS); -- restrict value to size return BIT_REMOVE (INTO_ITEM, START_AT, NBITS) + SHIFT_LEFT (ITEM, START_AT); end BIT_INSERT; function BIT_REMOVE (ITEM, START_AT, NBITS : INTEGER) return INTEGER is KEEP : INTEGER := 0; TEMP : INTEGER; begin if START_AT /= 0 then KEEP := ITEM mod (2 ** START_AT); end if; TEMP := SHIFT_RIGHT (ITEM, START_AT + NBITS); return SHIFT_LEFT (TEMP, START_AT + NBITS) + KEEP; end BIT_REMOVE; function SHIFT_LEFT (ITEM, NBITS : INTEGER) return INTEGER is begin return ITEM * (2 ** NBITS); end SHIFT_LEFT; function SHIFT_RIGHT (ITEM, NBITS : INTEGER) return INTEGER is begin return ITEM / (2 ** NBITS); end SHIFT_RIGHT; function BIT_AND (WORD1, WORD2 : INTEGER) return INTEGER is SPARE1 : INTEGER := WORD1; SPARE2 : INTEGER := WORD2; NEW_WORD : INTEGER := 0; BIT1, BIT2, NEW_BIT : INTEGER; begin -- -- the approach here to extract a single bit at a time from each -- word, and then decide upon the logical property. The loop -- continues until all bits of the word have been considered, -- or until the words become zero in the shifting process. -- for INDEX in 1 .. WORD_SIZE loop exit when SPARE1 = 0 and SPARE2 = 0; BIT1 := SPARE1 mod 2; -- get rightmost bit BIT2 := SPARE2 mod 2; if BIT1 = 1 and BIT2 = 1 then NEW_BIT := 1; -- decide upon new bit value else NEW_BIT := 0; end if; NEW_WORD := NEW_WORD + SHIFT_LEFT (NEW_BIT, INDEX - 1); SPARE1 := SHIFT_RIGHT (SPARE1, 1); SPARE2 := SHIFT_RIGHT (SPARE2, 1); end loop; return NEW_WORD; end BIT_AND; function BIT_OR (WORD1, WORD2 : INTEGER) return INTEGER is SPARE1 : INTEGER := WORD1; SPARE2 : INTEGER := WORD2; NEW_WORD : INTEGER := 0; BIT1, BIT2, NEW_BIT : INTEGER; begin -- processing is identical to BIT_AND, except the logical test is changed for INDEX in 1 .. WORD_SIZE loop exit when SPARE1 = 0 and SPARE2 = 0; BIT1 := SPARE1 mod 2; BIT2 := SPARE2 mod 2; if BIT1 = 1 or BIT2 = 1 then NEW_BIT := 1; else NEW_BIT := 0; end if; NEW_WORD := BIT_INSERT (NEW_BIT, 1, NEW_WORD, INDEX - 1); SPARE1 := SHIFT_RIGHT (SPARE1, 1); SPARE2 := SHIFT_RIGHT (SPARE2, 1); end loop; return NEW_WORD; end BIT_OR; function BIT_MASK (NBITS : INTEGER) return INTEGER is RESULT : INTEGER := 0; begin for INDEX in 1 .. NBITS loop RESULT := RESULT * 2 + 1; end loop; return RESULT; end BIT_MASK; end BIT_FUNCTIONS; --:::::::::: --bplustre.bdy --:::::::::: with Unchecked_Deallocation; package body BP_Tree is -- ************************************************************************************* -- ** This software is part of the Clemson University Computer Science Department's ** -- ** Ada Software Repository, and is copyrighted (C) 1989 by Clemson University. ** -- ** Permission to copy without fee all or part of this software is granted, ** -- ** provided that the copies are not made or distributed for direct commercial ** -- ** advantage, and that this copyright notice is not deleted or modified. To ** -- ** copy otherwise, or to republish, requires a fee and/or specific permission. ** -- ** >> All bug reporters receive a free updated copy once the bug's corrected! << ** -- ** E-mail to: cpscada@citron.cs.clemson.edu or ...!gatech!hubcap!citron!cpscada. ** -- ************************************************************************************* ---------------------------------------------------------------------------------------------------------------------------- type Internal_Node (Index_Node : Boolean); ---------------------------------------------------------------------------------------------------------------------------- type Internal_Node_Pointer is access Internal_Node; ---------------------------------------------------------------------------------------------------------------------------- Maximum_Number_Of_Subtrees_Per_Node : constant := 3; -- This can be any odd number >= 3... -- Unfortunately, due to limitations of Ada, -- this cannot be made into a generic parameter. ---------------------------------------------------------------------------------------------------------------------------- Minimum_Number_Of_Subtrees_Per_Node : constant := (Maximum_Number_Of_Subtrees_Per_Node/ 2) + 1; ---------------------------------------------------------------------------------------------------------------------------- Minimum_Subtree_Number : constant := Minimum_Number_Of_Subtrees_Per_Node - 1; ---------------------------------------------------------------------------------------------------------------------------- Maximum_Subtree_Number : constant := Maximum_Number_Of_Subtrees_Per_Node - 1; ---------------------------------------------------------------------------------------------------------------------------- type Subtrees is range 0..Maximum_Subtree_Number; ---------------------------------------------------------------------------------------------------------------------------- type Array_Of_Subtrees is array (Subtrees) of Internal_Node_Pointer; ---------------------------------------------------------------------------------------------------------------------------- Maximum_Number_Of_Keys_Per_Node : constant := Maximum_Number_Of_Subtrees_Per_Node - 1; ---------------------------------------------------------------------------------------------------------------------------- type Keys is range 1..Maximum_Number_Of_Keys_Per_Node; ---------------------------------------------------------------------------------------------------------------------------- type Key_Pointer is access Key_Type; ---------------------------------------------------------------------------------------------------------------------------- type Array_Of_Keys is array (Keys) of Key_Pointer; ---------------------------------------------------------------------------------------------------------------------------- type Internal_Node (Index_Node : Boolean) is record case Index_Node is when True => Maximum_Subtree_Index : Subtrees; Key : Array_Of_Keys; Subtree : Array_Of_Subtrees; when False => Preceding_Leaf : Internal_Node_Pointer := null; Following_Leaf : Internal_Node_Pointer := null; Key_Value : Key_Pointer; Item_Container : Non_Key_Item_Container; end case; end record; ---------------------------------------------------------------------------------------------------------------------------- type B_Plus_Tree_Descriptor is record Root_Node : Internal_Node_Pointer; Current_Leaf : Internal_Node_Pointer; Minimum_Key : Key_Pointer; Number_Of_Keys_Stored : Natural; end record; ---------------------------------------------------------------------------------------------------------------------------- type Non_Key_Item_Pointer is access Non_Key_Item_Type; ---------------------------------------------------------------------------------------------------------------------------- type Type_Of_Deletion is (Key, Non_Key_Object); ---------------------------------------------------------------------------------------------------------------------------- Null_Node_Pointer : Internal_Node_Pointer := null; -- acceptable as an {in out} parameter... Null_Key_Pointer : Key_Pointer := null; -- acceptable as an {in out} parameter... ---------------------------------------------------------------------------------------------------------------------------- function Empty (Targeted_B_Plus_Tree : in B_Plus_Tree) return Boolean is begin -- function Empty return (Targeted_B_Plus_Tree = null); end Empty; ---------------------------------------------------------------------------------------------------------------------------- function Number_Of_Keys_Stored (Targeted_B_Plus_Tree : in B_Plus_Tree) return Natural is begin -- function Number_Of_Keys_Stored if (Targeted_B_Plus_Tree = null) then return 0; else return Targeted_B_Plus_Tree.Number_Of_Keys_Stored; end if; end Number_Of_Keys_Stored; ---------------------------------------------------------------------------------------------------------------------------- procedure Exchange (First_Key_Pointer : in out Key_Pointer; Second_Key_Pointer : in out Key_Pointer) is Temp_Key_Pointer : Key_Pointer := First_Key_Pointer; begin -- procedure Exchange First_Key_Pointer := Second_Key_Pointer; Second_Key_Pointer := Temp_Key_Pointer; end Exchange; ---------------------------------------------------------------------------------------------------------------------------- procedure Exchange (First_Internal_Node_Pointer : in out Internal_Node_Pointer; Second_Internal_Node_Pointer : in out Internal_Node_Pointer) is Temp_Internal_Node_Pointer : Internal_Node_Pointer := First_Internal_Node_Pointer; begin -- procedure Exchange First_Internal_Node_Pointer := Second_Internal_Node_Pointer; Second_Internal_Node_Pointer := Temp_Internal_Node_Pointer; end Exchange; ---------------------------------------------------------------------------------------------------------------------------- procedure Exchange (First_B_Plus_Tree : in out B_Plus_Tree; Second_B_Plus_Tree : in out B_Plus_Tree) is Temporary_B_Plus_Tree : B_Plus_Tree := First_B_Plus_Tree; begin -- procedure Exchange First_B_Plus_Tree := Second_B_Plus_Tree; Second_B_Plus_Tree := Temporary_B_Plus_Tree; end Exchange; ---------------------------------------------------------------------------------------------------------------------------- function Determine_Path_Of_Descent (Targeted_Index_Node : in Internal_Node_Pointer; Key_Value : in Key_Type ) return Subtrees is Path_Number : Subtrees := 0; begin -- function Determine_Path_Of_Descent while (Path_Number < Maximum_Subtree_Number) and then ( Targeted_Index_Node.Key (Keys'Val (Subtrees'Pos (Path_Number) +1) ) /= null ) and then not Less_Than (Key_Value, Targeted_Index_Node.Key (Keys'Val (Subtrees'Pos(Path_Number)+1)).all) loop Path_Number := Path_Number + 1; end loop; return Path_Number; end Determine_Path_Of_Descent; ---------------------------------------------------------------------------------------------------------------------------- procedure Left_Shift (Node_Being_Shifted : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Leftmost_Shift_Point : in Subtrees; Rightmost_Shift_Point : in Subtrees ) is -- Assumption: Leftmost_Shift_Point > 0... begin -- procedure Left_Shift for Subtree_Number in Leftmost_Shift_Point..Rightmost_Shift_Point loop Node_Being_Shifted.Subtree (Subtree_Number - 1) := Node_Being_Shifted.Subtree (Subtree_Number); if (Subtree_Number > 1) then Node_Being_Shifted.Key ( Keys'Val (Subtrees'Pos (Subtree_Number - 1) ) ) := Node_Being_Shifted.Key ( Keys'Val (Subtrees'Pos (Subtree_Number) ) ); else Minimum_Key_In_Subtree := Node_Being_Shifted.Key ( Keys'Val (Subtrees'Pos (Subtree_Number) ) ); end if; end loop; end Left_Shift; ---------------------------------------------------------------------------------------------------------------------------- procedure Right_Shift (Node_Being_Shifted : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Leftmost_Shift_Point : in Subtrees; Rightmost_Shift_Point : in Subtrees ) is -- Assumption: Rightmost_Shift_Point < Maximum_Subtree_Number... begin -- procedure Right_Shift for Subtree_Number in reverse Leftmost_Shift_Point..Rightmost_Shift_Point loop Node_Being_Shifted.Subtree (Subtree_Number + 1) := Node_Being_Shifted.Subtree (Subtree_Number); if (Subtree_Number > 0) then Node_Being_Shifted.Key ( Keys'Val (Subtrees'Pos (Subtree_Number + 1) ) ) := Node_Being_Shifted.Key ( Keys'Val (Subtrees'Pos (Subtree_Number) ) ); else Node_Being_Shifted.Key (1) := Minimum_Key_In_Subtree; end if; end loop; end Right_Shift; ---------------------------------------------------------------------------------------------------------------------------- procedure Insert_Extra_Subtree (Targeted_Index_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_Extra_Subtree : in out Key_Pointer ) is -- Assumption: Targeted_Index_Node.Maximum_Subtree_Index < Maximum_Subtree_Number... Path_Of_Descent : Subtrees; Insertion_Point : Subtrees; begin -- procedure Insert_Extra_Subtree Path_Of_Descent := Determine_Path_Of_Descent (Targeted_Index_Node, Minimum_Key_In_Extra_Subtree.all); if (Path_Of_Descent > 0) or else Less_Than (Minimum_Key_In_Subtree.all, Minimum_Key_In_Extra_Subtree.all) then Insertion_Point := Path_Of_Descent + 1; else Insertion_Point := Path_Of_Descent; end if; Right_Shift (Targeted_Index_Node, Minimum_Key_In_Subtree, Insertion_Point, Targeted_Index_Node.Maximum_Subtree_Index); Targeted_Index_Node.Subtree (Insertion_Point) := Extra_Subtree; if (Insertion_Point = 0) then Minimum_Key_In_Subtree := Minimum_Key_In_Extra_Subtree; else Targeted_Index_Node.Key ( Keys'Val (Subtrees'Pos (Insertion_Point))) := Minimum_Key_In_Extra_Subtree; end if; Targeted_Index_Node.Maximum_Subtree_Index := Targeted_Index_Node.Maximum_Subtree_Index + 1; Extra_Subtree := null; Minimum_Key_In_Extra_Subtree := null; end Insert_Extra_Subtree; ---------------------------------------------------------------------------------------------------------------------------- procedure Delete_Subtree (Targeted_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Targeted_Subtree : in Subtrees ) is begin -- procedure Delete_Subtree if (Targeted_Subtree < Targeted_Node.Maximum_Subtree_Index) then Left_Shift (Targeted_Node, Minimum_Key_In_Subtree, (Targeted_Subtree+1), Targeted_Node.Maximum_Subtree_Index); end if; Targeted_Node.Subtree (Targeted_Node.Maximum_Subtree_Index) := null; if (Targeted_Node.Maximum_Subtree_Index = 0) then Minimum_Key_In_Subtree := null; else Targeted_Node.Key ( Keys'Val ( Subtrees'Pos (Targeted_Node.Maximum_Subtree_Index) ) ) := null; Targeted_Node.Maximum_Subtree_Index := Targeted_Node.Maximum_Subtree_Index - 1; end if; end Delete_Subtree; ---------------------------------------------------------------------------------------------------------------------------- procedure Insert_Item (Targeted_B_Plus_Tree : in out B_Plus_Tree; Key_Value : in Key_Type; Non_Key_Information : in Non_Key_Item_Type) is New_Root : Internal_Node_Pointer; Extra_Subtree : Internal_Node_Pointer := null; Minimum_Key_In_Extra_Subtree : Key_Pointer := null; procedure Generate_New_Leaf (Pointer_To_Preceding_Leaf : in Internal_Node_Pointer; Pointer_To_New_Leaf : in out Internal_Node_Pointer; Pointer_To_Following_Leaf : in Internal_Node_Pointer; Value_Of_New_Key : in Key_Type ) is begin -- procedure Generate_New_Leaf Pointer_To_New_Leaf := new Internal_Node (Index_Node => False); Pointer_To_New_Leaf.Preceding_Leaf := Pointer_To_Preceding_Leaf; Pointer_To_New_Leaf.Following_Leaf := Pointer_To_Following_Leaf; if (Pointer_To_Preceding_Leaf /= null) then Pointer_To_Preceding_Leaf.Following_Leaf := Pointer_To_New_Leaf; end if; if (Pointer_To_Following_Leaf /= null) then Pointer_To_Following_Leaf.Preceding_Leaf := Pointer_To_New_Leaf; end if; Pointer_To_New_Leaf.Key_Value := new Key_Type; Assign (Pointer_To_New_Leaf.Key_Value.all, Value_Of_New_Key); end Generate_New_Leaf; procedure Create_New_B_Plus_Tree (Targeted_B_Plus_Tree : in out B_Plus_Tree; Key_Value : in Key_Type; Non_Key_Information : in Non_Key_Item_Type) is begin -- procedure Create_New_B_Plus_Tree Targeted_B_Plus_Tree := new B_Plus_Tree_Descriptor; Targeted_B_Plus_Tree.Root_Node := new Internal_Node (Index_Node => True); Generate_New_Leaf (null, Targeted_B_Plus_Tree.Root_Node.Subtree(0), null, Key_Value); Insert (Targeted_B_Plus_Tree.Root_Node.Subtree(0).Item_Container, Non_Key_Information); Targeted_B_Plus_Tree.Current_Leaf := Targeted_B_Plus_Tree.Root_Node.Subtree(0); Targeted_B_Plus_Tree.Minimum_Key := Targeted_B_Plus_Tree.Root_Node.Subtree(0).Key_Value; Targeted_B_Plus_Tree.Root_Node.Maximum_Subtree_Index := 0; Targeted_B_Plus_Tree.Number_Of_Keys_Stored := 1; end Create_New_B_Plus_Tree; procedure Insert_Subtree (Left_Sibling : in out Internal_Node_Pointer; Minimum_Key_In_Left_Sibling : in out Key_Pointer; Targeted_Index_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Right_Sibling : in out Internal_Node_Pointer; Minimum_Key_In_Right_Sibling : in out Key_Pointer; Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_Extra_Subtree : in out Key_Pointer ) is Room_In_Left_Sibling : Boolean := ( (Left_Sibling /= null) and then (Left_Sibling.Index_Node = True) and then (Left_Sibling.Maximum_Subtree_Index < Maximum_Subtree_Number) ); Room_In_Right_Sibling : Boolean := ( (Right_Sibling /= null) and then (Right_Sibling.Index_Node = True) and then (Right_Sibling.Maximum_Subtree_Index < Maximum_Subtree_Number) ); type Overflow_Preference is (Return_Leftmost_Subtree, Return_Rightmost_Subtree); procedure Insert_And_Overflow (Targeted_Index_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_Extra_Subtree : in out Key_Pointer; Overflow_Directions : in Overflow_Preference ) is Temp_Subtree : Internal_Node_Pointer; Temp_Key : Key_Pointer; Insertion_Point : Subtrees := Determine_Path_Of_Descent (Targeted_Index_Node, Minimum_Key_In_Extra_Subtree.all); begin -- procedure Insert_And_Overflow if (Overflow_Directions = Return_Leftmost_Subtree) then if (Insertion_Point = 0) then if Less_Than (Minimum_Key_In_Subtree.all, Minimum_Key_In_Extra_Subtree.all) then Exchange (Targeted_Index_Node.Subtree(0), Extra_Subtree); Exchange (Minimum_Key_In_Extra_Subtree, Minimum_Key_In_Subtree); end if; else Temp_Subtree := Targeted_Index_Node.Subtree(0); Temp_Key := Minimum_Key_In_Subtree; Left_Shift (Targeted_Index_Node, Minimum_Key_In_Subtree, 1, Insertion_Point); Targeted_Index_Node.Subtree (Insertion_Point) := Extra_Subtree; Targeted_Index_Node.Key (Keys'Val(Subtrees'Pos(Insertion_Point))) := Minimum_Key_In_Extra_Subtree; Extra_Subtree := Temp_Subtree; Minimum_Key_In_Extra_Subtree := Temp_Key; end if; elsif (Overflow_Directions = Return_Rightmost_Subtree) then if (Insertion_Point + 1 >= Maximum_Subtree_Number) then if not Less_Than (Targeted_Index_Node.Key (Maximum_Subtree_Number).all, Minimum_Key_In_Extra_Subtree.all) then Exchange (Extra_Subtree, Targeted_Index_Node.Subtree (Maximum_Subtree_Number) ); Exchange (Minimum_Key_In_Extra_Subtree, Targeted_Index_Node.Key (Keys'Val (Subtrees'Pos (Maximum_Subtree_Number) ) ) ); end if; else if not (Insertion_Point = 0) or else Less_Than (Minimum_Key_In_Subtree.all, Minimum_Key_In_Extra_Subtree.all) then Insertion_Point := Insertion_Point + 1; end if; Temp_Subtree := Targeted_Index_Node.Subtree (Maximum_Subtree_Number); Temp_Key := Targeted_Index_Node.Key (Maximum_Subtree_Number); Right_Shift (Targeted_Index_Node, Minimum_Key_In_Subtree, Insertion_Point, (Maximum_Subtree_Number - 1)); Targeted_Index_Node.Subtree (Insertion_Point) := Extra_Subtree; if (Insertion_Point = 0) then Minimum_Key_In_Subtree := Minimum_Key_In_Extra_Subtree; else Targeted_Index_Node.Key ( Keys'Val ( Subtrees'Pos ( Insertion_Point ) ) ) := Minimum_Key_In_Extra_Subtree; end if; Extra_Subtree := Temp_Subtree; Minimum_Key_In_Extra_Subtree := Temp_Key; end if; end if; end Insert_And_Overflow; procedure Insert_And_Partition (Targeted_Index_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_Extra_Subtree : in out Key_Pointer ) is Insertion_Point : Subtrees; New_Extra_Subtree : Internal_Node_Pointer; Minimum_Key_In_New_Extra_Subtree : Key_Pointer; procedure Partition (Targeted_Index_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Node_Split_Point : in Subtrees; New_Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_New_Extra_Subtree : in out Key_Pointer ) is begin -- procedure Partition New_Extra_Subtree := new Internal_Node (Index_Node => True); for Transferred_Subtree_Index in reverse Node_Split_Point..Maximum_Subtree_Number loop New_Extra_Subtree.Subtree (Transferred_Subtree_Index - Node_Split_Point) := Targeted_Index_Node.Subtree (Transferred_Subtree_Index); Targeted_Index_Node.Subtree (Transferred_Subtree_Index) := null; if (Transferred_Subtree_Index - Node_Split_Point) > 0 then New_Extra_Subtree.Key (Keys'Val ( Subtrees'Pos (Transferred_Subtree_Index - Node_Split_Point))) := Targeted_Index_Node.Key (Keys'Val ( Subtrees'Pos (Transferred_Subtree_Index))); else Minimum_Key_In_New_Extra_Subtree := Targeted_Index_Node.Key (Keys'Val (Subtrees'Pos (Transferred_Subtree_Index) ) ); end if; Targeted_Index_Node.Key (Keys'Val (Subtrees'Pos (Transferred_Subtree_Index))) := null; end loop; Targeted_Index_Node.Maximum_Subtree_Index := Node_Split_Point - 1; New_Extra_Subtree.Maximum_Subtree_Index := Maximum_Subtree_Number - Node_Split_Point; end Partition; begin -- procedure Insert_And_Partition Insertion_Point := Determine_Path_Of_Descent (Targeted_Index_Node, Minimum_Key_In_Extra_Subtree.all); if (Insertion_Point < Minimum_Subtree_Number) then Partition (Targeted_Index_Node, Minimum_Key_In_Subtree, Minimum_Subtree_Number, New_Extra_Subtree, Minimum_Key_In_New_Extra_Subtree); Insert_Extra_Subtree (Targeted_Index_Node, Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree); else Partition (Targeted_Index_Node, Minimum_Key_In_Subtree, Minimum_Subtree_Number + 1, New_Extra_Subtree, Minimum_Key_In_New_Extra_Subtree); Insert_Extra_Subtree (New_Extra_Subtree, Minimum_Key_In_New_Extra_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; Extra_Subtree := New_Extra_Subtree; Minimum_Key_In_Extra_Subtree := Minimum_Key_In_New_Extra_Subtree; end Insert_And_Partition; begin -- procedure Insert_Subtree if (Targeted_Index_Node.Maximum_Subtree_Index < Maximum_Subtree_Number) then Insert_Extra_Subtree (Targeted_Index_Node, Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree); elsif Room_In_Left_Sibling and not Room_In_Right_Sibling then Insert_And_Overflow (Targeted_Index_Node, Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree, Return_Leftmost_Subtree); Insert_Extra_Subtree (Left_Sibling, Minimum_Key_In_Left_Sibling, Extra_Subtree, Minimum_Key_In_Extra_Subtree); elsif Room_In_Right_Sibling then Insert_And_Overflow (Targeted_Index_Node, Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree, Return_Rightmost_Subtree); Insert_Extra_Subtree (Right_Sibling, Minimum_Key_In_Right_Sibling, Extra_Subtree, Minimum_Key_In_Extra_Subtree); else Insert_And_Partition (Targeted_Index_Node, Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; end Insert_Subtree; procedure Descend_And_Insert_Leaf (Left_Sibling : in Internal_Node_Pointer; Target_Node : in Internal_Node_Pointer; Right_Sibling : in Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Extra_Subtree : in out Internal_Node_Pointer; Minimum_Key_In_Extra_Subtree : in out Key_Pointer ) is Path_Of_Descent : Subtrees; begin -- procedure Descend_And_Insert_Leaf if (Target_Node.Index_Node = False) then if Equal (Target_Node.Key_Value.all, Key_Value) then Insert (Target_Node.Item_Container, Non_Key_Information); Targeted_B_Plus_Tree.Current_Leaf := Target_Node; else if Less_Than (Key_Value, Target_Node.Key_Value.all) then Generate_New_Leaf (Target_Node.Preceding_Leaf, Extra_Subtree, Target_Node, Key_Value); else Generate_New_Leaf (Target_Node, Extra_Subtree, Target_Node.Following_Leaf, Key_Value); end if; Insert (Extra_Subtree.Item_Container, Non_Key_Information); Minimum_Key_In_Extra_Subtree := Extra_Subtree.Key_Value; Targeted_B_Plus_Tree.Current_Leaf := Extra_Subtree; Targeted_B_Plus_Tree.Number_Of_Keys_Stored := Targeted_B_Plus_Tree.Number_Of_Keys_Stored + 1; end if; else Path_Of_Descent := Determine_Path_Of_Descent (Target_Node, Key_Value); case Path_Of_Descent is when 0 => Descend_And_Insert_Leaf (Null_Node_Pointer, Target_Node.Subtree (0), Target_Node.Subtree (1), Minimum_Key_In_Subtree, Extra_Subtree, Minimum_Key_In_Extra_Subtree); if (Extra_Subtree /= null) and (Target_Node.Subtree (Path_Of_Descent).all.Index_Node = True) then Insert_Subtree (Null_Node_Pointer, Null_Key_Pointer, Target_Node.Subtree (0), Minimum_Key_In_Subtree, Target_Node.Subtree (1), Target_Node.Key (1), Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; when 1..(Maximum_Subtree_Number - 1) => Descend_And_Insert_Leaf (Target_Node.Subtree (Path_Of_Descent - 1), Target_Node.Subtree (Path_Of_Descent), Target_Node.Subtree (Path_Of_Descent + 1), Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent))), Extra_Subtree, Minimum_Key_In_Extra_Subtree); if (Extra_Subtree /= null) and (Target_Node.Subtree (Path_Of_Descent).Index_Node = True) then if (Path_Of_Descent = 1) then Insert_Subtree (Target_Node.Subtree (0), Minimum_Key_In_Subtree, Target_Node.Subtree (1), Target_Node.Key (1), Target_Node.Subtree (2), Target_Node.Key (2), Extra_Subtree, Minimum_Key_In_Extra_Subtree); else Insert_Subtree (Target_Node.Subtree (Path_Of_Descent - 1), Target_Node.Key (Keys'Val (Subtrees'Pos (Path_Of_Descent - 1))), Target_Node.Subtree (Path_Of_Descent), Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent))), Target_Node.Subtree (Path_Of_Descent + 1), Target_Node.Key ( Keys'Val (Subtrees'Pos (Path_Of_Descent-1))), Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; end if; when Maximum_Subtree_Number => Descend_And_Insert_Leaf (Target_Node.Subtree (Maximum_Subtree_Number - 1), Target_Node.Subtree (Maximum_Subtree_Number), Null_Node_Pointer, Target_Node.Key (Maximum_Subtree_Number), Extra_Subtree, Minimum_Key_In_Extra_Subtree); if (Extra_Subtree /= null) and (Target_Node.Subtree (Path_Of_Descent).Index_Node = True) then Insert_Subtree (Target_Node.Subtree (Maximum_Subtree_Number - 1), Target_Node.Key (Maximum_Subtree_Number - 1), Target_Node.Subtree (Maximum_Subtree_Number), Target_Node.Key (Maximum_Subtree_Number), Null_Node_Pointer, Null_Key_Pointer, Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; end case; end if; end Descend_And_Insert_Leaf; begin -- procedure Insert_Item if (Targeted_B_Plus_Tree = null) then Create_New_B_Plus_Tree (Targeted_B_Plus_Tree, Key_Value, Non_Key_Information); else Descend_And_Insert_Leaf (null, Targeted_B_Plus_Tree.Root_Node, null, Targeted_B_Plus_Tree.Minimum_Key, Extra_Subtree, Minimum_Key_In_Extra_Subtree); if (Extra_Subtree /= null) then Insert_Subtree (Null_Node_Pointer, Null_Key_Pointer, Targeted_B_Plus_Tree.Root_Node, Targeted_B_Plus_Tree.Minimum_Key, Null_Node_Pointer, Null_Key_Pointer, Extra_Subtree, Minimum_Key_In_Extra_Subtree); end if; if (Extra_Subtree /= null) then New_Root := new Internal_Node (Index_Node => True); New_Root.Subtree(0) := Targeted_B_Plus_Tree.Root_Node; New_Root.Subtree(1) := Extra_Subtree; New_Root.Key(1) := Minimum_Key_In_Extra_Subtree; New_Root.Maximum_Subtree_Index := 1; Targeted_B_Plus_Tree.Root_Node := New_Root; end if; end if; end Insert_Item; ---------------------------------------------------------------------------------------------------------------------------- procedure Destroy is new Unchecked_Deallocation (Key_Type, Key_Pointer); ---------------------------------------------------------------------------------------------------------------------------- procedure Destroy is new Unchecked_Deallocation (Internal_Node, Internal_Node_Pointer); ---------------------------------------------------------------------------------------------------------------------------- procedure Annihilate is new Unchecked_Deallocation (B_Plus_Tree_Descriptor, B_Plus_Tree); ---------------------------------------------------------------------------------------------------------------------------- procedure Destroy_Subtree (Target_Node : in out Internal_Node_Pointer) is begin -- procedure Destroy_Subtree if (Target_Node /= null) then if (Target_Node.Index_Node = False) then if (Target_Node.Preceding_Leaf /= null) then Target_Node.Preceding_Leaf.Following_Leaf := Target_Node.Following_Leaf; end if; if (Target_Node.Following_Leaf /= null) then Target_Node.Following_Leaf.Preceding_Leaf := Target_Node.Preceding_Leaf; end if; Destroy (Target_Node.Key_Value); Destroy_Contents (Target_Node.Item_Container); Destroy (Target_Node); else for Subtree_Number in Subtrees loop Destroy_Subtree (Target_Node.Subtree (Subtree_Number)); end loop; Destroy (Target_Node); end if; end if; end Destroy_Subtree; ---------------------------------------------------------------------------------------------------------------------------- procedure Destroy (Targeted_B_Plus_Tree : in out B_Plus_Tree) is -- Destroys all keys and all associated containers, and renders the tree Empty. begin -- procedure Destroy if not Empty (Targeted_B_Plus_Tree) then Destroy_Subtree (Targeted_B_Plus_Tree.Root_Node); Annihilate (Targeted_B_Plus_Tree); end if; end Destroy; ---------------------------------------------------------------------------------------------------------------------------- procedure Destroy (Targeted_Object : in out Pointer_To_B_Plus_Tree) is procedure Annihilate is new Unchecked_Deallocation (B_Plus_Tree, Pointer_To_B_Plus_Tree); begin -- procedure Destroy if (Targeted_Object /= null) then Destroy (Targeted_Object.all); Annihilate (Targeted_Object); end if; end Destroy; ---------------------------------------------------------------------------------------------------------------------------- procedure Descend_And_Delete (Targeted_B_Plus_Tree : in out B_Plus_Tree; Target_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Deletion_Type : in Type_Of_Deletion; Target_Key : in Key_Type; Target_Non_Key_Object : in Non_Key_Item_Type) is Path_Of_Descent : Subtrees; procedure Delete_From_Leaf (Target_Leaf : in out Internal_Node_Pointer; Deletion_Type : in Type_Of_Deletion; Target_Key : in Key_Type; Target_Non_Key_Object : in Non_Key_Item_Type) is procedure Delete_Leaf (Targeted_B_Plus_Tree : in out B_Plus_Tree; Target_Leaf : in out Internal_Node_Pointer) is begin -- procedure Delete_Leaf if (Targeted_B_Plus_Tree.Current_Leaf = Target_Leaf) then Targeted_B_Plus_Tree.Current_Leaf := null; end if; if (Targeted_B_Plus_Tree.Minimum_Key = Target_Leaf.Key_Value) then if (Target_Leaf.Following_Leaf /= null) then Targeted_B_Plus_Tree.Minimum_Key := Target_Leaf.Following_Leaf.Key_Value; else Targeted_B_Plus_Tree.Minimum_Key := null; end if; end if; Destroy_Subtree (Target_Leaf); Targeted_B_Plus_Tree.Number_Of_Keys_Stored := Targeted_B_Plus_Tree.Number_Of_Keys_Stored - 1; end Delete_Leaf; begin -- procedure Delete_From_Leaf if not Equal (Target_Leaf.Key_Value.all, Target_Key) then raise Key_Does_Not_Exist_In_This_B_Plus_Tree; elsif (Deletion_Type = Non_Key_Object) then Delete (Target_Leaf.Item_Container, Target_Non_Key_Object); if Empty (Target_Leaf.Item_Container) then Delete_Leaf (Targeted_B_Plus_Tree, Target_Leaf); end if; else -- (Deletion_Type = Key) Delete_Leaf (Targeted_B_Plus_Tree, Target_Leaf); end if; end Delete_From_Leaf; procedure Redistribute_Subtrees (Target_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : in out Key_Pointer; Path_Of_Descent : in Subtrees ) is Needy_Node : Internal_Node_Pointer; Minimum_Key_In_Needy_Node : Key_Pointer; Left_Sibling : Internal_Node_Pointer := null; Minimum_Key_In_Left_Sibling : Key_Pointer := null; Right_Sibling : Internal_Node_Pointer := null; Minimum_Key_In_Right_Sibling : Key_Pointer := null; Extras_In_Left_Sibling : Boolean; Extras_In_Right_Sibling : Boolean; begin -- procedure Redistribute_Subtrees Needy_Node := Target_Node.Subtree (Path_Of_Descent); if (Path_Of_Descent = 0) then Minimum_Key_In_Needy_Node := Minimum_Key_In_Subtree; else Minimum_Key_In_Needy_Node := Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent) ) ); end if; case Path_Of_Descent is when 0 => Right_Sibling := Target_Node.Subtree (1); Minimum_Key_In_Right_Sibling := Target_Node.Key (1); when 1 => Left_Sibling := Target_Node.Subtree (0); Minimum_Key_In_Left_Sibling := Minimum_Key_In_Subtree; Right_Sibling := Target_Node.Subtree (2); Minimum_Key_In_Right_Sibling := Target_Node.Key (2); when 2..(Maximum_Subtree_Number - 1) => Left_Sibling := Target_Node.Subtree (Path_Of_Descent - 1); Minimum_Key_In_Left_Sibling := Target_Node.Key (Keys'Val(Subtrees'Pos(Path_Of_Descent - 1))); Right_Sibling := Target_Node.Subtree (Path_Of_Descent + 1); Minimum_Key_In_Right_Sibling := Target_Node.Key (Keys'Val(Subtrees'Pos(Path_Of_Descent + 1))); when Maximum_Subtree_Number => Left_Sibling := Target_Node.Subtree (Maximum_Subtree_Number - 1); Minimum_Key_In_Left_Sibling := Target_Node.Key (Maximum_Subtree_Number - 1); end case; Extras_In_Left_Sibling := ( (Left_Sibling /= null) and then (Left_Sibling.Index_Node = True) and then (Left_Sibling.Maximum_Subtree_Index > Minimum_Subtree_Number)); Extras_In_Right_Sibling := ( (Right_Sibling /= null) and then (Right_Sibling.Index_Node = True) and then (Right_Sibling.Maximum_Subtree_Index > Minimum_Subtree_Number)); if Extras_In_Left_Sibling and not Extras_In_Right_Sibling then Insert_Extra_Subtree (Needy_Node, Minimum_Key_In_Needy_Node, Left_Sibling.Subtree (Left_Sibling.Maximum_Subtree_Index), Left_Sibling.Key (Keys'Val(Subtrees'Pos(Left_Sibling.Maximum_Subtree_Index)))); Delete_Subtree (Left_Sibling, Minimum_Key_In_Left_Sibling, Left_Sibling.Maximum_Subtree_Index); Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent) ) ) := Minimum_Key_In_Needy_Node; elsif Extras_In_Right_Sibling then Insert_Extra_Subtree (Needy_Node, Minimum_Key_In_Needy_Node, Right_Sibling.Subtree(0), Minimum_Key_In_Right_Sibling); Delete_Subtree (Right_Sibling, Minimum_Key_In_Right_Sibling, 0); Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent + 1) ) ) := Minimum_Key_In_Right_Sibling; elsif (Right_Sibling = null) or else (Left_Sibling /= null) then Insert_Extra_Subtree (Left_Sibling, Minimum_Key_In_Left_Sibling, Needy_Node.Subtree (0), Minimum_Key_In_Needy_Node); for Subtree_Number in 1..Needy_Node.Maximum_Subtree_Index loop Insert_Extra_Subtree (Left_Sibling, Minimum_Key_In_Left_Sibling, Needy_Node.Subtree (Subtree_Number), Needy_Node.Key ( Keys'Val ( Subtrees'Pos ( Subtree_Number ) ) ) ); end loop; Destroy (Needy_Node); Delete_Subtree (Target_Node, Minimum_Key_In_Subtree, Path_Of_Descent); else Insert_Extra_Subtree (Needy_Node, Minimum_Key_In_Needy_Node, Right_Sibling.Subtree (0), Minimum_Key_In_Right_Sibling); for Subtree_Number in 1..Right_Sibling.Maximum_Subtree_Index loop Insert_Extra_Subtree (Needy_Node, Minimum_Key_In_Needy_Node, Right_Sibling.Subtree (Subtree_Number), Right_Sibling.Key ( Keys'Val ( Subtrees'Pos ( Subtree_Number)))); end loop; Destroy (Right_Sibling); Delete_Subtree (Target_Node, Minimum_Key_In_Subtree, Path_Of_Descent + 1); end if; end Redistribute_Subtrees; begin -- procedure Descend_And_Delete if (Target_Node.Index_Node = False) then Delete_From_Leaf (Target_Node, Deletion_Type, Target_Key, Target_Non_Key_Object); else Path_Of_Descent := Determine_Path_Of_Descent (Target_Node, Target_Key); if (Path_Of_Descent = 0) then Descend_And_Delete ( Targeted_B_Plus_Tree, Target_Node.Subtree (0), Minimum_Key_In_Subtree, Deletion_Type, Target_Key, Target_Non_Key_Object ); else Descend_And_Delete ( Targeted_B_Plus_Tree, Target_Node.Subtree (Path_Of_Descent), Target_Node.Key ( Keys'Val ( Subtrees'Pos (Path_Of_Descent) ) ), Deletion_Type, Target_Key, Target_Non_Key_Object ); end if; if (Target_Node.Subtree (Path_Of_Descent) = null) then Delete_Subtree (Target_Node, Minimum_Key_In_Subtree, Path_Of_Descent); elsif (Target_Node.Subtree (Path_Of_Descent).Index_Node = True) and then (Target_Node.Subtree (Path_Of_Descent).Maximum_Subtree_Index < Minimum_Subtree_Number) then Redistribute_Subtrees (Target_Node, Minimum_Key_In_Subtree, Path_Of_Descent); end if; end if; end Descend_And_Delete; ---------------------------------------------------------------------------------------------------------------------------- procedure Delete_Key (Targeted_B_Plus_Tree : in out B_Plus_Tree; Search_Key : in Key_Type ) is -- Raises Key_Does_Not_Exist_In_This_B_Plus_Tree -- or No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree, when appropriate... -- -- The Non_Key_Item_Container associated with this key will be emptied via the Destroy_Contents procedure. Null_Non_Key_Information : Non_Key_Item_Type; begin -- procedure Delete_Key if Empty (Targeted_B_Plus_Tree) then raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; else Descend_And_Delete (Targeted_B_Plus_Tree, Targeted_B_Plus_Tree.Root_Node, Targeted_B_Plus_Tree.Minimum_Key, Key, Search_Key, Null_Non_Key_Information); end if; end Delete_Key; ---------------------------------------------------------------------------------------------------------------------------- procedure Delete_Item (Targeted_B_Plus_Tree : in out B_Plus_Tree; Key_Value : in Key_Type; Non_Key_Information : in Non_Key_Item_Type) is -- Raises Key_Does_Not_Exist_In_This_B_Plus_Tree -- or No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree, when appropriate... begin -- procedure Delete_Item if Empty (Targeted_B_Plus_Tree) then raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; else Descend_And_Delete (Targeted_B_Plus_Tree, Targeted_B_Plus_Tree.Root_Node, Targeted_B_Plus_Tree.Minimum_Key, Non_Key_Object, Key_Value, Non_Key_Information); Targeted_B_Plus_Tree.Current_Leaf := null; if (Targeted_B_Plus_Tree.Root_Node.Maximum_Subtree_Index = 0) then if (Targeted_B_Plus_Tree.Root_Node.Subtree(0) /= null) then if (Targeted_B_Plus_Tree.Root_Node.Subtree(0).Index_Node = True) then declare Temp_Root : Internal_Node_Pointer := Targeted_B_Plus_Tree.Root_Node.Subtree(0); begin Destroy (Targeted_B_Plus_Tree.Root_Node); Targeted_B_Plus_Tree.Root_Node := Temp_Root; end; end if; else Destroy (Targeted_B_Plus_Tree.Root_Node); Destroy (Targeted_B_Plus_Tree); end if; end if; end if; end Delete_Item; ---------------------------------------------------------------------------------------------------------------------------- function Get_First_Key (Targeted_B_Plus_Tree : in B_Plus_Tree) return Key_Type is -- Raises No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree when appropriate... begin -- function Get_First_Key if Empty (Targeted_B_Plus_Tree) then raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; else return Targeted_B_Plus_Tree.Minimum_Key.all; end if; end Get_First_Key; ---------------------------------------------------------------------------------------------------------------------------- function Get_Last_Key (Targeted_B_Plus_Tree : in B_Plus_Tree) return Key_Type is -- Raises No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree when appropriate... function Return_Last_Key (This_Subtree : Internal_Node_Pointer) return Key_Type is begin -- function Return_Last_Key if (This_Subtree.Index_Node = True) then return Return_Last_Key (This_Subtree.Subtree(This_Subtree.Maximum_Subtree_Index)); else return This_Subtree.Key_Value.all; end if; end Return_Last_Key; begin -- function Get_Last_Key if Empty (Targeted_B_Plus_Tree) then raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; else return Return_Last_Key (Targeted_B_Plus_Tree.Root_Node); end if; end Get_Last_Key; ---------------------------------------------------------------------------------------------------------------------------- function Get_Leaf_Node (This_B_Plus_Tree : in B_Plus_Tree; Key_Value : in Key_Type ) return Internal_Node_Pointer is function Find_Leaf_Node (This_Subtree : in Internal_Node_Pointer; Key_Value : in Key_Type ) return Internal_Node_Pointer is Path_Number : Subtrees := 0; begin -- function Find_Leaf_Node if (This_Subtree.Index_Node = True) then while (Path_Number < This_Subtree.Maximum_Subtree_Index) and then not Less_Than (Key_Value, This_Subtree.Key(Keys'Val(Subtrees'Pos(Path_Number) + 1)).all) loop Path_Number := Path_Number + 1; end loop; return Find_Leaf_Node (This_Subtree.Subtree(Path_Number), Key_Value); else if Equal (This_Subtree.Key_Value.all, Key_Value) then return This_Subtree; else return null; end if; end if; end Find_Leaf_Node; begin -- function Get_Leaf_Node if not Empty (This_B_Plus_Tree) then if (This_B_Plus_Tree.Current_Leaf /= null) and then Equal (This_B_Plus_Tree.Current_Leaf.Key_Value.all, Key_Value) then return This_B_Plus_Tree.Current_Leaf; else return Find_Leaf_Node (This_B_Plus_Tree.Root_Node, Key_Value); end if; else return null; end if; end Get_Leaf_Node; ---------------------------------------------------------------------------------------------------------------------------- function Key_Exists (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Boolean is begin -- function Key_Exists if not Empty (Targeted_B_Plus_Tree) then Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); return (Targeted_B_Plus_Tree.Current_Leaf /= null); else return False; end if; end Key_Exists; ---------------------------------------------------------------------------------------------------------------------------- function Get_Item_Container (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Non_Key_Item_Container is -- Raises Key_Does_Not_Exist_In_This_B_Plus_Tree -- or No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree, when appropriate... begin -- function Get_Item_Container if Empty (Targeted_B_Plus_Tree) then raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; else Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); if (Targeted_B_Plus_Tree.Current_Leaf = null) then raise Key_Does_Not_Exist_In_This_B_Plus_Tree; else return Targeted_B_Plus_Tree.Current_Leaf.Item_Container; end if; end if; end Get_Item_Container; ---------------------------------------------------------------------------------------------------------------------------- function A_Preceding_Key_Exists (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Boolean is begin -- function A_Preceding_Key_Exists Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); return ( not Empty (Targeted_B_Plus_Tree) and then (Targeted_B_Plus_Tree.Current_Leaf /= null) and then (Targeted_B_Plus_Tree.Current_Leaf.Preceding_Leaf /= null) ); end A_Preceding_Key_Exists; ---------------------------------------------------------------------------------------------------------------------------- function Get_Preceding_Key (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Key_Type is -- Raises Key_Does_Not_Exist_In_This_B_Plus_Tree -- or No_Preceding_Key_Exists_In_This_B_Plus_Tree -- or No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree, when appropriate... Temp : Key_Type; begin -- function Get_Preceding_Key if not Empty (Targeted_B_Plus_Tree) then Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); if (Targeted_B_Plus_Tree.Current_Leaf /= null) and then (Targeted_B_Plus_Tree.Current_Leaf.Preceding_Leaf /= null) then return Targeted_B_Plus_Tree.Current_Leaf.Preceding_Leaf.Key_Value.all; elsif (Targeted_B_Plus_Tree.Current_Leaf.Preceding_Leaf = null) then raise No_Preceding_Key_Exists_In_This_B_Plus_Tree; elsif (Targeted_B_Plus_Tree.Current_Leaf = null) then raise Key_Does_Not_Exist_In_This_B_Plus_Tree; end if; else raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; end if; end Get_Preceding_Key; ---------------------------------------------------------------------------------------------------------------------------- function A_Following_Key_Exists (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Boolean is begin -- function A_Following_Key_Exists Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); return ( not Empty (Targeted_B_Plus_Tree) and then (Targeted_B_Plus_Tree.Current_Leaf /= null) and then (Targeted_B_Plus_Tree.Current_Leaf.Following_Leaf /= null) ); end A_Following_Key_Exists; ---------------------------------------------------------------------------------------------------------------------------- function Get_Following_Key (Targeted_B_Plus_Tree : in B_Plus_Tree; Search_Key : in Key_Type ) return Key_Type is -- Raises Key_Does_Not_Exist_In_This_B_Plus_Tree -- or No_Following_Key_Exists_In_This_B_Plus_Tree -- or No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree, when appropriate... begin -- function Get_Following_Key if not Empty (Targeted_B_Plus_Tree) then Targeted_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (Targeted_B_Plus_Tree, Search_Key); if (Targeted_B_Plus_Tree.Current_Leaf /= null) and then (Targeted_B_Plus_Tree.Current_Leaf.Following_Leaf /= null) then return Targeted_B_Plus_Tree.Current_Leaf.Following_Leaf.Key_Value.all; elsif (Targeted_B_Plus_Tree.Current_Leaf.Following_Leaf = null) then raise No_Following_Key_Exists_In_This_B_Plus_Tree; elsif (Targeted_B_Plus_Tree.Current_Leaf = null) then raise Key_Does_Not_Exist_In_This_B_Plus_Tree; end if; else raise No_Keys_Currently_Exist_In_This_Empty_B_Plus_Tree; end if; end Get_Following_Key; ---------------------------------------------------------------------------------------------------------------------------- procedure Assign (To_B_Plus_Tree : in out B_Plus_Tree; From_B_Plus_Tree : in B_Plus_Tree) is Last_Leaf : Internal_Node_Pointer; procedure Assign (To_Internal_Node : in out Internal_Node_Pointer; Minimum_Key_In_Subtree : out Key_Pointer; From_Internal_Node : in Internal_Node_Pointer) is begin -- procedure Assign To_Internal_Node := new Internal_Node (Index_Node => From_Internal_Node.Index_Node); if From_Internal_Node.Index_Node then To_Internal_Node.Maximum_Subtree_Index := From_Internal_Node.Maximum_Subtree_Index; Assign (To_Internal_Node.Subtree (0), Minimum_Key_In_Subtree, From_Internal_Node.Subtree (0)); for Subtree_Number in 1..From_Internal_Node.Maximum_Subtree_Index loop Assign (To_Internal_Node.Subtree (Subtree_Number), To_Internal_Node.Key ( Keys'Val ( Subtrees'Pos (Subtree_Number) ) ), From_Internal_Node.Subtree (Subtree_Number)); end loop; else To_Internal_Node.Preceding_Leaf := Last_Leaf; Last_Leaf.Following_Leaf := To_Internal_Node; To_Internal_Node.Key_Value := new Key_Type; Assign (To_Internal_Node.Key_Value.all, From_Internal_Node.Key_Value.all); Assign (To_Internal_Node.Item_Container, From_Internal_Node.Item_Container); Last_Leaf := To_Internal_Node; end if; end Assign; begin -- procedure Assign Destroy (To_B_Plus_Tree); if (From_B_Plus_Tree /= null) then To_B_Plus_Tree := new B_Plus_Tree_Descriptor; Assign (To_B_Plus_Tree.Root_Node, To_B_Plus_Tree.Minimum_Key, From_B_Plus_Tree.Root_Node); To_B_Plus_Tree.Current_Leaf := Get_Leaf_Node (To_B_Plus_Tree, From_B_Plus_Tree.Current_Leaf.Key_Value.all); To_B_Plus_Tree.Number_Of_Keys_Stored := From_B_Plus_Tree.Number_Of_Keys_Stored; end if; end Assign; ---------------------------------------------------------------------------------------------------------------------------- end BP_Tree; --:::::::::: --cisc.bdy --:::::::::: package body case_insensitive_string_comparison is --| Overview --| Strings are compared one character at a time, stopping as soon as --| possible. --| Programmer: M. Gordon ------------------------------------------------------------------------ Up_ConvertArray: array(Character) of Character; Down_ConvertArray: array(Character) of Character; Difference: constant := Character'pos('a') - Character'pos('A'); function toUpper(C: character) return character is begin return Up_ConvertArray(C); end toUpper; function upCase( --| Return copy of S with all characters lower case S: String ) return String is R: String(S'Range) := S; begin for i in R'Range loop R(i) := toUpper(R(i)); end loop; return R; end upCase; procedure upCase( --| Convert all characters in S to lower case S: in out String ) is begin for i in S'Range loop S(i) := toUpper(S(i)); end loop; end upCase; ------------------------------------------------------------------------ function toLower(C: character) return character is begin return Down_ConvertArray(C); end toLower; function downCase( --| Return copy of S with all characters lower case S: String ) return String is R: String(S'Range) := S; begin for i in R'Range loop R(i) := toLower(R(i)); end loop; return R; end downCase; procedure downCase( --| Convert all characters in S to lower case S: in out String ) is begin for i in S'Range loop S(i) := toLower(S(i)); end loop; end downCase; ------------------------------------------------------------------------ function compare( --| Compare two strings P, Q: String ) return integer is QI: natural; PC, QC: character; begin QI := Q'First; for PI in P'First .. P'Last loop if QI > Q'Last then return 1; -- Q ran out before P did. end if; PC := toUpper(P(PI)); QC := toUpper(Q(QI)); if PC /= QC then return character'pos(PC) - character'pos(QC); end if; QI := QI + 1; end loop; return P'Length - Q'Length; -- Equal so far: longer string is greater end compare; ------------------------------------------------------------------------ function equal( P, Q: String ) return boolean is begin return compare(P, Q) = 0; end equal; ------------------------------------------------------------------------ function less( P, Q: String ) return boolean is begin return compare(P, Q) < 0; end less; function less_or_equal( P, Q: String ) return boolean is begin return compare(P, Q) <= 0; end less_or_equal; ------------------------------------------------------------------------ function greater( P, Q: String ) return boolean is begin return compare(P, Q) > 0; end greater; function greater_or_equal( P, Q: String ) return boolean is begin return compare(P, Q) >= 0; end greater_or_equal; ------------------------------------------------------------------------ begin for I in Character loop case I is when 'a' .. 'z' => Up_ConvertArray(I) := Character'val(Character'pos(I) - Difference); when others => Up_ConvertArray(I) := I; end case; end loop; for I in Character loop case I is when 'A' .. 'Z' => Down_ConvertArray(I) := Character'val(Character'pos(I) + Difference); when others => Down_ConvertArray(I) := I; end case; end loop; end case_insensitive_string_comparison; --:::::::::: --cset.bdy --:::::::::: package body CHARACTER_SET is function TO_LOWER (CH : in CHARACTER) return CHARACTER is begin return LOWER (CH); end TO_LOWER; procedure TO_LOWER (CH : in out CHARACTER) is begin CH := LOWER (CH); end TO_LOWER; procedure TO_LOWER (STR : in out STRING) is begin for I in STR'FIRST .. STR'LAST loop STR (I) := LOWER (STR (I)); end loop; end TO_LOWER; function TO_UPPER (CH : in CHARACTER) return CHARACTER is begin return UPPER (CH); end TO_UPPER; procedure TO_UPPER (CH : in out CHARACTER) is begin CH := UPPER (CH); end TO_UPPER; procedure TO_UPPER (STR : in out STRING) is begin for I in STR'FIRST .. STR'LAST loop STR (I) := UPPER (STR (I)); end loop; end TO_UPPER; function CC_NAME_2 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_2 is NAME : CONTROL_CHARACTER_NAME_2; begin case CH is when ASCII.NUL => NAME := "^@"; when ASCII.SOH => NAME := "^A"; when ASCII.STX => NAME := "^B"; when ASCII.ETX => NAME := "^C"; when ASCII.EOT => NAME := "^D"; when ASCII.ENQ => NAME := "^E"; when ASCII.ACK => NAME := "^F"; when ASCII.BEL => NAME := "^G"; when ASCII.BS => NAME := "^H"; when ASCII.HT => NAME := "^I"; when ASCII.LF => NAME := "^J"; when ASCII.VT => NAME := "^K"; when ASCII.FF => NAME := "^L"; when ASCII.CR => NAME := "^M"; when ASCII.SO => NAME := "^N"; when ASCII.SI => NAME := "^O"; when ASCII.DLE => NAME := "^P"; when ASCII.DC1 => NAME := "^Q"; when ASCII.DC2 => NAME := "^R"; when ASCII.DC3 => NAME := "^S"; when ASCII.DC4 => NAME := "^T"; when ASCII.NAK => NAME := "^U"; when ASCII.SYN => NAME := "^V"; when ASCII.ETB => NAME := "^W"; when ASCII.CAN => NAME := "^X"; when ASCII.EM => NAME := "^Y"; when ASCII.SUB => NAME := "^Z"; when ASCII.ESC => NAME := "^["; when ASCII.FS => NAME := "^\"; when ASCII.GS => NAME := "^]"; when ASCII.RS => NAME := "^^"; when ASCII.US => NAME := "^_"; when ASCII.DEL => NAME := "^`"; when others => NAME := " "; NAME (2) := CH; end case; return NAME; end CC_NAME_2; function CC_NAME_3 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_3 is NAME : CONTROL_CHARACTER_NAME_3; begin case CH is when ASCII.NUL => NAME := "NUL"; when ASCII.SOH => NAME := "SOH"; when ASCII.STX => NAME := "STX"; when ASCII.ETX => NAME := "ETX"; when ASCII.EOT => NAME := "EOT"; when ASCII.ENQ => NAME := "ENQ"; when ASCII.ACK => NAME := "ACK"; when ASCII.BEL => NAME := "BEL"; when ASCII.BS => NAME := "BS "; when ASCII.HT => NAME := "HT "; when ASCII.LF => NAME := "LF "; when ASCII.VT => NAME := "VT "; when ASCII.FF => NAME := "FF "; when ASCII.CR => NAME := "CR "; when ASCII.SO => NAME := "SO "; when ASCII.SI => NAME := "SI "; when ASCII.DLE => NAME := "DLE"; when ASCII.DC1 => NAME := "DC1"; when ASCII.DC2 => NAME := "DC2"; when ASCII.DC3 => NAME := "DC3"; when ASCII.DC4 => NAME := "DC4"; when ASCII.NAK => NAME := "NAK"; when ASCII.SYN => NAME := "SYN"; when ASCII.ETB => NAME := "ETB"; when ASCII.CAN => NAME := "CAN"; when ASCII.EM => NAME := "EM "; when ASCII.SUB => NAME := "SUB"; when ASCII.ESC => NAME := "ESC"; when ASCII.FS => NAME := "FS "; when ASCII.GS => NAME := "GS "; when ASCII.RS => NAME := "RS "; when ASCII.US => NAME := "US "; when ASCII.DEL => NAME := "DEL"; when others => NAME := " "; NAME (2) := CH; end case; return NAME; end CC_NAME_3; end CHARACTER_SET; --:::::::::: --cssc.bdy --:::::::::: package body case_sensitive_string_comparison is --| Overview --| Strings are compared one character at a time, stopping as soon as --| possible. --| Programmer: M. Gordon ------------------------------------------------------------------------ function compare( --| Compare two strings P, Q: String ) return integer is QI: natural; begin QI := Q'First; for PI in P'First .. P'Last loop if QI > Q'Last then return 1; -- Q ran out before P did. end if; if P(PI) /= Q(QI) then return character'pos(P(PI)) - character'pos(Q(QI)); end if; QI := QI + 1; end loop; return P'Length - Q'Length; -- Equal so far: longer string is greater end compare; ------------------------------------------------------------------------ function equal( P, Q: String ) return boolean is begin return P = Q; end equal; ------------------------------------------------------------------------ function less( P, Q: String ) return boolean is begin return P < Q; end less; function less_or_equal( P, Q: String ) return boolean is begin return P <= Q; end less_or_equal; ------------------------------------------------------------------------ function greater( P, Q: String ) return boolean is begin return P > Q; end greater; function greater_or_equal( P, Q: String ) return boolean is begin return P >= Q; end greater_or_equal; ------------------------------------------------------------------------ end case_sensitive_string_comparison; --:::::::::: --cstrings.bdy --:::::::::: -- ******************************************************** -- * * -- * CStrings * BODY -- * * -- ******************************************************** package body CStrings is --| Notes --| Reference Sun Release 4.0 man pages on "strings". Work : STRING(1..Max_String_Length); Work2 : STRING(1..Max_String_Length); Work3 : STRING(1..Max_String_Length); Charpos_LC_A : constant := CHARACTER'POS('a'); Charpos_UC_A : constant := CHARACTER'POS('A'); -- ................................................... -- . . -- . CStrings.Toupper . SPEC & BODY -- . . -- ................................................... function Toupper (Item : in CHARACTER) return CHARACTER is Result : CHARACTER := Item; begin if Item in 'a' .. 'z' then Result := CHARACTER'VAL(CHARACTER'POS(Item) - Charpos_LC_A + Charpos_UC_A); end if; return Result; end Toupper; pragma inline (Toupper); -- ................................................... -- . . -- . CStrings.Char_is_in_String . SPEC & BODY -- . . -- ................................................... function Char_is_in_String (Ch : in CHARACTER; S : in STRING) return BOOLEAN is begin return Strchr(S, Ch) /= 0; end Char_is_in_String; pragma inline (Char_is_in_String); -- ................................................... -- . . -- . CStrings.Copy . SPEC & BODY -- . . -- ................................................... procedure Copy (Source : in STRING; Destination : out STRING; D_Start : in NATURAL) is --| Note --| Any exception raised here (probably CONSTRAINT_ERROR) --| is to be handled by the caller. S : NATURAL; begin S := Strlen(Source); if S > 0 then Destination(D_Start..D_Start+S-1) := Source(Source'FIRST .. Source'FIRST+S-1); end if; Destination(D_Start+S) := ASCII.NUL; end Copy; pragma inline (Copy); -- ................................................... -- . . -- . CStrings.Make_Cstring . BODY -- . . -- ................................................... procedure Make_Cstring (From : in STRING; To : out STRING) is begin To(To'FIRST .. To'FIRST + From'LENGTH - 1) := From; To(To'FIRST + From'LENGTH) := ASCII.NUL; exception when others => raise LENGTH_ERROR; end Make_Cstring; -- ................................................... -- . . -- . CStrings.Make_Cstring . BODY -- . . -- ................................................... procedure Make_Cstring (From_To : in out STRING; Index : in NATURAL) is begin From_To(Index) := ASCII.NUL; exception when others => raise LENGTH_ERROR; end Make_Cstring; -- ................................................... -- . . -- . CStrings.Ada_String . BODY -- . . -- ................................................... function Ada_String (From : in STRING) return STRING is begin return From(From'FIRST .. From'FIRST + Strlen(From) - 1); end Ada_String; -- ................................................... -- . . -- . CStrings.Strcat . BODY -- . . -- ................................................... procedure Strcat (To : in out STRING; From : in STRING) is begin Copy(To, Work, Work'FIRST); Copy(From, Work, Work'FIRST + Strlen(To)); Copy(Work, To, To'FIRST); exception when others => raise LENGTH_ERROR; end Strcat; -- ................................................... -- . . -- . CStrings.Strcat . BODY -- . . -- ................................................... function Strcat (From_Part_1 : in STRING; From_Part_2 : in STRING) return STRING is --| Note --| Buffer Work2 is used because procedure Strcat uses --| buffer Work. begin Strcpy(From_Part_1, Work2); Strcat(Work2, From_Part_2); return Work2(Work2'FIRST .. Work2'FIRST + Strlen(Work2)); exception when others => raise LENGTH_ERROR; end Strcat; -- ................................................... -- . . -- . CStrings.Strncat . BODY -- . . -- ................................................... procedure Strncat (To : in out STRING; From : in STRING; Length : in NATURAL) is --| Note --| Buffer Work2 is used because procedure Strcat uses --| buffer Work. begin Copy(From, Work2, Work2'FIRST); Work2(Work2'FIRST + Length) := ASCII.NUL; Strcat(To, Work2); exception when others => raise LENGTH_ERROR; end Strncat; -- ................................................... -- . . -- . CStrings.Strncat . BODY -- . . -- ................................................... function Strncat (To : in STRING; From : in STRING; Length : in NATURAL) return STRING is --| Note --| Buffer Work3 is used because procedure Strcat uses --| buffer Work and procedure Strncat uses buffer Work2. begin Copy(To, Work3, Work3'FIRST); Strncat(Work3, From, Length); return Work3(Work3'FIRST .. Work3'FIRST + Strlen(Work3)); exception when others => raise LENGTH_ERROR; end Strncat; -- ................................................... -- . . -- . CStrings.Strcmp . BODY -- . . -- ................................................... function Strcmp (String1 : in STRING; String2 : in STRING) return COMPARISON_RESULT is Result : COMPARISON_RESULT := EQUAL_TO; S1 : NATURAL := String1'FIRST; S2 : NATURAL := String2'FIRST; Loop_Exit : BOOLEAN; begin if String1'LENGTH > 0 and String2'LENGTH > 0 then -- Both strings are not empty (contain at least -- ASCII.NUL) while String1(S1) /= ASCII.NUL loop -- loop thru String1, comparing it char-for-char -- with String2 Loop_Exit := FALSE; -- indicates abnormal loop exit if String1(S1) /= String2(S2) then -- if the two chars are not the same, -- then we can determine a result if String1(S1) < String2(S2) then Result := LESS_THAN; else Result := GREATER_THAN; end if; exit; end if; -- the two strings are the same so far, so -- continue advancing thru them S1 := S1 + 1; S2 := S2 + 1; -- done if we are past the ends of both strings exit when S1 > String1'LAST and S2 > String2'LAST; -- we can determine the result if we are past the -- end of String1 but not String2 if S1 > String1'LAST then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; exit; end if; -- we can determine the result if we are past the -- end of String2 but not String1 if S2 > String2'LAST then if String1(S1) /= ASCII.NUL then Result := GREATER_THAN; end if; exit; end if; Loop_Exit := TRUE; -- indicates normal exit of loop end loop; -- we have exited the loop either normally or abnormally -- (abnormally is via an exit statement); if normally, -- then we have reached the end of String1 and the result -- is EQUAL_TO unless we have also reached the end of -- String2 if Loop_Exit then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; end if; else -- one of the strings is empty, so determine the -- result (Result is already EQUAL_TO, so if either -- string has some length, then Result changes) if String1'LENGTH > 0 then Result := GREATER_THAN; elsif String2'LENGTH > 0 then Result := LESS_THAN; end if; end if; -- Result is the answer return Result; end Strcmp; -- ................................................... -- . . -- . CStrings.Strncmp . BODY -- . . -- ................................................... function Strncmp (String1 : in STRING; String2 : in STRING; Length : in NATURAL) return COMPARISON_RESULT is Result : COMPARISON_RESULT := EQUAL_TO; S1 : NATURAL := String1'FIRST; S2 : NATURAL := String2'FIRST; Count : NATURAL := Length; Loop_Exit : BOOLEAN; begin if (String1'LENGTH > 0 and String2'LENGTH > 0) and (Count > 0) then -- Both strings are not empty (contain at least -- ASCII.NUL) and Count is non-zero while String1(S1) /= ASCII.NUL loop -- loop thru String1, comparing it char-for-char -- with String2 Loop_Exit := FALSE; -- indicates abnormal loop exit if String1(S1) /= String2(S2) then -- if the two chars are not the same, -- then we can determine a result if String1(S1) < String2(S2) then Result := LESS_THAN; else Result := GREATER_THAN; end if; exit; end if; -- the two strings are the same so far, so -- continue advancing thru them S1 := S1 + 1; S2 := S2 + 1; -- done if we have exhausted the count Count := Count - 1; exit when Count = 0; -- done if we are past the ends of both strings exit when S1 > String1'LAST and S2 > String2'LAST; -- we can determine the result if we are past the -- end of String1 but not String2 if S1 > String1'LAST then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; exit; end if; -- we can determine the result if we are past the -- end of String2 but not String1 if S2 > String2'LAST then if String1(S2) /= ASCII.NUL then Result := GREATER_THAN; end if; exit; end if; Loop_Exit := TRUE; -- indicates normal exit of loop end loop; -- we have exited the loop either normally or abnormally -- (abnormally is via an exit statement); if normally, -- then we have reached the end of String1 and the result -- is EQUAL_TO unless we have also reached the end of -- String2 if Loop_Exit and (Count > 0) then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; end if; else -- one of the strings is empty, so determine the -- result (Result is already EQUAL_TO, so if either -- string has some length, then Result changes) if Count > 0 then -- proceed only if Count > 0 if String1'LENGTH > 0 then Result := GREATER_THAN; elsif String2'LENGTH > 0 then Result := LESS_THAN; end if; end if; end if; -- Result is the answer return Result; end Strncmp; -- ................................................... -- . . -- . CStrings.Strcasecmp . BODY -- . . -- ................................................... function Strcasecmp (String1 : in STRING; String2 : in STRING) return COMPARISON_RESULT is --| Notes --| This is not commented well because the same --| comments as in Strcmp apply except that Toupper --| is always called on the characters being compared Result : COMPARISON_RESULT := EQUAL_TO; S1 : NATURAL := String1'FIRST; S2 : NATURAL := String2'FIRST; Loop_Exit : BOOLEAN; begin if String1'LENGTH > 0 and String2'LENGTH > 0 then while String1(S1) /= ASCII.NUL loop Loop_Exit := FALSE; if Toupper(String1(S1)) /= Toupper(String2(S2)) then if Toupper(String1(S1)) < Toupper(String2(S2)) then Result := LESS_THAN; else Result := GREATER_THAN; end if; exit; end if; S1 := S1 + 1; S2 := S2 + 1; exit when S1 > String1'LAST and S2 > String2'LAST; if S1 > String1'LAST then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; exit; end if; if S2 > String2'LAST then if String1(S1) /= ASCII.NUL then Result := GREATER_THAN; end if; exit; end if; Loop_Exit := TRUE; end loop; if Loop_Exit then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; end if; else if String1'LENGTH > 0 then Result := GREATER_THAN; elsif String2'LENGTH > 0 then Result := LESS_THAN; end if; end if; return Result; end Strcasecmp; -- ................................................... -- . . -- . CStrings.Strncasecmp . BODY -- . . -- ................................................... function Strncasecmp (String1 : in STRING; String2 : in STRING; Length : in NATURAL) return COMPARISON_RESULT is --| Notes --| This is not commented well because the same --| comments as in Strncmp apply except that Toupper --| is always called on the characters being compared Result : COMPARISON_RESULT := EQUAL_TO; S1 : NATURAL := String1'FIRST; S2 : NATURAL := String2'FIRST; Count : NATURAL := Length; Loop_Exit : BOOLEAN; begin if (String1'LENGTH > 0 and String2'LENGTH > 0) and (Count > 0) then while String1(S1) /= ASCII.NUL loop Loop_Exit := FALSE; if Toupper(String1(S1)) /= Toupper(String2(S2)) then if Toupper(String1(S1)) < Toupper(String2(S2)) then Result := LESS_THAN; else Result := GREATER_THAN; end if; exit; end if; S1 := S1 + 1; S2 := S2 + 1; Count := Count - 1; exit when Count = 0; exit when S1 > String1'LAST and S2 > String2'LAST; if S1 > String1'LAST then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; exit; end if; if S2 > String2'LAST then if String1(S1) /= ASCII.NUL then Result := GREATER_THAN; end if; exit; end if; Loop_Exit := TRUE; end loop; if Loop_Exit and (Count > 0) then if String2(S2) /= ASCII.NUL then Result := LESS_THAN; end if; end if; else if Count > 0 then if String1'LENGTH > 0 then Result := GREATER_THAN; elsif String2'LENGTH > 0 then Result := LESS_THAN; end if; end if; end if; return Result; end Strncasecmp; -- ................................................... -- . . -- . CStrings.Strcpy . BODY -- . . -- ................................................... procedure Strcpy (From : in STRING; To : out STRING) is begin Copy(From, To, To'FIRST); exception when others => raise LENGTH_ERROR; end Strcpy; -- ................................................... -- . . -- . CStrings.Strncpy . BODY -- . . -- ................................................... procedure Strncpy (From : in STRING; To : out STRING; Length : in NATURAL) is S : NATURAL := From'FIRST; D : NATURAL := To'FIRST; Count : NATURAL := Length; begin -- do not attempt copy if From is empty if From'LENGTH > 0 then -- perform a char-for-char copy, checking for -- ASCII.NUL, end of From buffer, and end of Count while From(S) /= ASCII.NUL loop To(D) := From(S); D := D + 1; S := S + 1; exit when S > From'LAST; Count := Count - 1; exit when Count = 0; end loop; end if; To(D) := ASCII.NUL; exception when others => raise LENGTH_ERROR; end Strncpy; -- ................................................... -- . . -- . CStrings.Strlen . BODY -- . . -- ................................................... function Strlen (String1 : in STRING) return NATURAL is Result : NATURAL := 0; S : NATURAL := String1'FIRST; begin if S <= String1'LAST then while String1(S) /= ASCII.NUL loop Result := Result + 1; S := S + 1; exit when S > String1'LAST; end loop; end if; return Result; end Strlen; -- ................................................... -- . . -- . CStrings.Strchr . BODY -- . . -- ................................................... function Strchr (String1 : in STRING; Char1 : in CHARACTER) return NATURAL is Result : NATURAL := 0; S : NATURAL := String1'FIRST; begin if String1'LENGTH > 0 then -- if String1 is not empty, do char-by-char -- compare while String1(S) /= ASCII.NUL loop if String1(S) = Char1 then Result := S; exit; end if; S := S + 1; exit when S > String1'LAST; end loop; end if; return Result; end Strchr; -- ................................................... -- . . -- . CStrings.Strrchr . BODY -- . . -- ................................................... function Strrchr (String1 : in STRING; Char1 : in CHARACTER) return NATURAL is Result : NATURAL := 0; S : NATURAL; begin S := Strlen(String1); if S > 0 then -- search only if the string is not empty S := String1'FIRST + Strlen(String1) - 1; -- index of last char loop if String1(S) = Char1 then Result := S; exit; end if; exit when S = String1'FIRST; S := S - 1; end loop; end if; return Result; end Strrchr; -- ................................................... -- . . -- . CStrings.Strpbrk . BODY -- . . -- ................................................... function Strpbrk (String1 : in STRING; String2 : in STRING) return NATURAL is Result : NATURAL := 0; S1 : NATURAL := String1'FIRST; begin if String1'LENGTH > 0 then -- search only if String1 is not empty while String1(S1) /= ASCII.NUL loop if Char_is_in_String (String1(S1), String2) then Result := S1; exit; end if; S1 := S1 + 1; exit when S1 > String1'LAST; end loop; end if; return Result; end Strpbrk; -- ................................................... -- . . -- . CStrings.Strspn . BODY -- . . -- ................................................... function Strspn (String1 : in STRING; String2 : in STRING) return NATURAL is S1 : NATURAL := String1'FIRST; Result : NATURAL := 0; begin if String1'LENGTH > 0 then -- search only if String1 is not empty while String1(S1) /= ASCII.NUL loop if Char_is_in_String (String1(S1), String2) then Result := 1; S1 := S1 + 1; exit; end if; S1 := S1 + 1; exit when S1 > String1'LAST; end loop; -- at this point, Result=1 if we found a char if Result = 1 and S1 <= String1'LAST then -- we have found one of the chars and are not done, -- so look for rest of the chars while String1(S1) /= ASCII.NUL loop if Char_is_in_String (String1(S1), String2) then Result := Result + 1; else exit; end if; S1 := S1 + 1; exit when S1 > String1'LAST; end loop; end if; end if; return Result; end Strspn; -- ................................................... -- . . -- . CStrings.Strcspn . BODY -- . . -- ................................................... function Strcspn (String1 : in STRING; String2 : in STRING) return NATURAL is S1 : NATURAL := String1'First; Result : NATURAL := 0; begin if String1'LENGTH > 0 then -- do this only if String1 is not empty while String1(S1) /= ASCII.NUL loop if not Char_is_in_String (String1(S1), String2) then Result := 1; S1 := S1 + 1; exit; end if; S1 := S1 + 1; exit when S1 > String1'LAST; end loop; -- Result=1 means we have not found one of the chars if Result = 1 and S1 <= String1'LAST then -- look for limit to non-matching string while String1(S1) /= ASCII.NUL loop if not Char_is_in_String (String1(S1), String2) then Result := Result + 1; else exit; end if; S1 := S1 + 1; exit when S1 > String1'LAST; end loop; end if; end if; return Result; end Strcspn; -- ................................................... -- . . -- . CStrings.Strtok . BODY -- . . -- ................................................... procedure Strtok (Target : in STRING; Start : in out NATURAL; Delimiters : in STRING; Next_Token : out STRING) is Next_Rover : NATURAL := Next_Token'FIRST; begin if Start > Target'LAST then -- Done if past the end of the string Next_Token(Next_Rover) := ASCII.NUL; else -- skip over leading delimiters while Start <= Target'LAST and then (Char_is_in_String (Target(Start), Delimiters) and Target(Start) /= ASCII.NUL) loop Start := Start + 1; end loop; -- Start is now index of first char, so begin extraction -- of token into Next_Token buffer while Start <= Target'LAST and then (not Char_is_in_String (Target(Start), Delimiters) and Target(Start) /= ASCII.NUL) loop Next_Token(Next_Rover) := Target(Start); Next_Rover := Next_Rover + 1; Start := Start + 1; exit when Start > Target'LAST; end loop; -- Start is either index of delimiter after last char -- of token or index of ASCII.NUL after Target string Next_Token(Next_Rover) := ASCII.NUL; end if; exception when others => raise LENGTH_ERROR; end Strtok; end CStrings; --:::::::::: --darray.bdy --:::::::::: with unchecked_deallocation; package body darray_pkg is -- Utilities: procedure free_array_ptr is new unchecked_deallocation(array_type, array_ptr); procedure free_darray is new unchecked_deallocation(darray_info, darray); function down_index(i: integer; d: darray) return integer; --| Raises: out_of_bounds --| Effects: --| Map from abstraction indices to representation indices. --| Raises out_of_bounds iff either is_empty(d) or i is not in --| d.first..last(d). --| Requires: d must be initialized. procedure initialization_check(d: darray); --| Raises: uninitialized_darray --| Effects: --| Returns normally iff d has been the target of a create, copy, --| or array_to_darray operation, and has not since been destroyed. --| Otherwise, raises uninitialized_darray. --| This procedure will not detect the case where another object --| sharing the same darray value has been destroyed; this is --| erroneous use. procedure expand(d: in out darray); --| Effects: --| Allocates additional space in d.arr. The old contents of d.arr --| are copied to a slice of the new array. The expansion amount is --| a percentage (d.expand_percent) of currently allocated space. --| Sets d.first_idx and d.last_idx to appropriate positions in the --| new array; these positions are selected according to the --| expected distribution of add_highs/add_lows (d.high_percent). --| Requires: d must be initialized. procedure contract(d: in out darray); --| Effects: --| Checks whether d.arr consumes too much space in proportion to --| the slice that is being used to hold the darray elements. If --| so, halves the size of d.arr. The old contents of d.arr are --| copied to a slice of the new array. Sets d.first_idx and --| and d.last_idx to appropriate positions in the new array; these --| positions are selected according to the expected distribution of --| add_highs/add_lows (d.high_percent). --| Requires: d must be initialized and nonempty. procedure reallocate(d: in out darray; new_length: in positive); --| Raises: out_of_bounds --| Effects: --| Replaces d.arr with a pointer to an array of length new_length, --| fills a slice of this array with the old contents of d.arr, and --| adjusts d.first_idx and d.last_idx appropriately. Everything is --| done according to d.high_percent. Used by both expand/contract. --| Raises out_of_bounds iff new_length < length(d). --| Requires: d must be initialized. procedure determine_position(array_length: in positive; slice_length: in natural; high_percent: in positive; first_idx: out positive; last_idx: out natural); --| Raises: out_of_bounds --| Effects: --| Determines the appropriate position of a slice of length --| slice_length in an array with range 1..array_length. This --| position is calculated according to the high_percent parameter. --| Raises out_of_bounds iff slice_length > array_length. --| Used by create, array_to_darray, reallocate. -- Constructors: procedure create(first: in integer := 1; predict: in positive := default_predict; high_percent: in positive := default_high; expand_percent: in positive := default_expand; d: in out darray) is begin destroy(d); d := new darray_info; determine_position(predict, 0, high_percent, d.first_idx, d.last_idx); d.first := first; d.high_percent := high_percent; d.expand_percent := expand_percent; d.arr := new array_type(1..predict); exception when out_of_bounds => -- determine_position fails destroy(d); raise; end create; procedure array_to_darray(a: in array_type; first: in integer:= 1; predict: in positive; high_percent: in positive := default_high; expand_percent: in positive := default_expand; d: in out darray) is begin free_array_ptr(d.arr); d := new darray_info; determine_position(predict, a'length, high_percent, d.first_idx, d.last_idx); d.first := first; d.high_percent := high_percent; d.expand_percent := expand_percent; d.arr := new array_type(1..predict); d.arr.all := a; exception when out_of_bounds => -- determine_position fails destroy(d); raise; end array_to_darray; procedure set_first(d: in out darray; first: in integer) is begin initialization_check(d); d.first := first; end set_first; procedure add_low(d: in out darray; e: in elem_type) is begin initialization_check(d); d.arr(d.first_idx - 1) := e; d.first_idx := d.first_idx - 1; d.first := d.first - 1; exception when constraint_error => -- on array store expand(d); d.arr(d.first_idx - 1) := e; d.first_idx := d.first_idx - 1; d.first := d.first - 1; end add_low; procedure add_high(d: in out darray; e: in elem_type) is begin initialization_check(d); d.arr(d.last_idx + 1) := e; d.last_idx := d.last_idx + 1; exception when constraint_error => -- on array store expand(d); d.arr(d.last_idx + 1) := e; d.last_idx := d.last_idx + 1; end add_high; procedure remove_low(d: in out darray) is begin initialization_check(d); if d.last_idx < d.first_idx then raise out_of_bounds; end if; d.first_idx := d.first_idx + 1; d.first := d.first + 1; contract(d); end remove_low; procedure remove_high(d: in out darray) is begin initialization_check(d); if d.last_idx < d.first_idx then raise out_of_bounds; end if; d.last_idx := d.last_idx - 1; contract(d); end remove_high; procedure store(d: in out darray; i: in integer; e: in elem_type) is begin initialization_check(d); d.arr(down_index(i, d)) := e; end store; function copy(d: darray) return darray is d2: darray; begin initialization_check(d); d2 := new darray_info'(first_idx => d.first_idx, last_idx => d.last_idx, first => d.first, high_percent => d.high_percent, expand_percent => d.expand_percent, arr => new array_type(1..d.arr'length)); d2.arr.all := d.arr.all; return d2; end copy; function copy_deep(d: darray) return darray is d2: darray; begin initialization_check(d); d2 := new darray_info'(first_idx => d.first_idx, last_idx => d.last_idx, first => d.first, high_percent => d.high_percent, expand_percent => d.expand_percent, arr => new array_type(1..d.arr'length)); for i in d.first_idx..d.last_idx loop d2.arr(i) := copy(d.arr(i)); end loop; return d2; end copy_deep; -- Query Operations: function fetch(d: darray; i: integer) return elem_type is begin initialization_check(d); return d.arr(down_index(i, d)); end fetch; function low(d: in darray) return elem_type is begin initialization_check(d); return d.arr(down_index(d.first, d)); end low; function high(d: in darray) return elem_type is begin if is_empty(d) then -- is_empty checks for initialization raise out_of_bounds; end if; return d.arr(d.last_idx); end high; function first(d: in darray) return integer is begin initialization_check(d); return d.first; end first; function last(d: in darray) return integer is begin initialization_check(d); return d.first + d.last_idx - d.first_idx; end last; function is_empty(d: in darray) return boolean is begin initialization_check(d); return d.last_idx < d.first_idx; end is_empty; function length(d: in darray) return natural is begin initialization_check(d); return d.last_idx - d.first_idx + 1; end length; function equal(d1, d2: darray) return boolean is i2: integer; begin initialization_check(d1); initialization_check(d2); if d1.first /= d2.first or else length(d1) /= length(d2) then return false; end if; i2 := d2.first_idx; for i1 in d1.first_idx..d1.last_idx loop if not equal(d1.arr(i1), d2.arr(i2)) then return false; end if; i2 := i2 + 1; end loop; return true; end equal; function darray_to_array(d: darray) return array_type is subtype dbounds_array is array_type(d.first..last(d)); -- invocation of last performs initialization check. begin return dbounds_array'(d.arr(d.first_idx..d.last_idx)); end darray_to_array; -- Iterators: function make_elements_iter(d: darray) return elements_iter is begin initialization_check(d); return (current => d.first_idx, last => d.last_idx, arr => d.arr); end make_elements_iter; function more(iter: elements_iter) return boolean is begin return iter.current <= iter.last; end more; procedure next(iter: in out elements_iter; e: out elem_type) is begin if not more(iter) then raise no_more; end if; e := iter.arr(iter.current); iter.current := iter.current + 1; end next; -- Heap Management: procedure destroy(d: in out darray) is begin free_array_ptr(d.arr); free_darray(d); exception when constraint_error => -- d is null, d.arr is illegal. return; end destroy; -- Utilities: function down_index(i: integer; d: darray) return integer is down_idx: integer := i - d.first + d.first_idx; begin if d.last_idx < d.first_idx or else -- empty array not (down_idx in d.first_idx..d.last_idx) then -- bogus index raise out_of_bounds; end if; return down_idx; end down_index; procedure initialization_check(d: darray) is begin if d = null then raise uninitialized_darray; end if; end initialization_check; procedure expand(d: in out darray) is new_length: integer := (d.arr'length * (100 + d.expand_percent))/100; begin -- Specified percent, in relation to length, may be too small to -- force any growth. In this case, force growth. This is rare. -- The choice to double is arbitrary. if new_length = d.arr'length then new_length := 2 * d.arr'length; end if; reallocate(d, new_length); end expand; procedure contract(d: in out darray) is -- <<A better contraction strategy is needed. Justification is weak -- for this one.>> begin null; end contract; procedure reallocate(d: in out darray; new_length: in positive) is new_arr: array_ptr; new_first_idx: integer; new_last_idx: integer; begin determine_position(new_length, length(d), d.high_percent, new_first_idx, new_last_idx); new_arr := new array_type(1..new_length); new_arr(new_first_idx..new_last_idx) := d.arr(d.first_idx..d.last_idx); free_array_ptr(d.arr); d.arr := new_arr; d.first_idx := new_first_idx; d.last_idx := new_last_idx; end reallocate; procedure determine_position(array_length: in positive; slice_length: in natural; high_percent: in positive; first_idx: out positive; last_idx: out natural) is left_over: integer := array_length - slice_length; high_space: integer := (high_percent * left_over)/100; low_space: integer := left_over - high_space; begin if left_over < 0 then raise out_of_bounds; end if; first_idx := low_space + 1; last_idx := low_space + slice_length; end determine_position; end darray_pkg; --:::::::::: --dlist.bdy --:::::::::: package body DOUBLY_LINKED_LIST is --======================================================================= -- General-purpose routines --======================================================================= procedure ALLOCATE (ID : in out LIST_ID; ITEM : in ELEMENT_OBJECT; RESULT : out ELEMENT_POINTER) is NEW_ELEMENT : ELEMENT_POINTER; begin if ID.FREE = null then NEW_ELEMENT := new ELEMENT'(CONTENT => ITEM, NEXT => null, PREVIOUS => null); else NEW_ELEMENT := ID.FREE; ID.FREE := NEW_ELEMENT.NEXT; NEW_ELEMENT.CONTENT := ITEM; NEW_ELEMENT.NEXT := null; NEW_ELEMENT.PREVIOUS := null; end if; RESULT := NEW_ELEMENT; exception when others => raise DYNAMIC_MEMORY_ALLOCATION_PROBLEM; end ALLOCATE; procedure ADD_TO_FREE (ID : in out LIST_ID; ITEM : in ELEMENT_POINTER) is begin if ID.FREE = null then ID.FREE := ITEM; ID.FREE.NEXT := null; else ITEM.NEXT := ID.FREE; ID.FREE := ITEM; end if; end ADD_TO_FREE; --======================================================================= -- Initialize --======================================================================= procedure INITIALIZE (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| INITIALIZE initializes the list to empty. If the list --| contained any elements, they are prefixed to the free --| list. --|DESIGN DESCRIPTION: --| If the free list is empty (FREE is NULL) --| Set FREE to point to the first element (FIRST) --| Else --| If the current list is not empty (FIRST /= NULL) --| Set LAST.NEXT to point to the free list (FREE) --| Set FREE to point to the old list (FIRST) --| End if --| End if --| Set FIRST to NULL --| Set LAST to NULL --| Set CURRENT to NULL --| Set NUMBER_OF_ELEMENTS to 0 --| Set CURRENT_INDEX to 0 --============================================================== begin if ID.FREE = null then ID.FREE := ID.FIRST; else if ID.FIRST /= null then ID.LAST.NEXT := ID.FREE; ID.FREE := ID.FIRST; end if; end if; ID.FIRST := null; ID.LAST := null; ID.CURRENT := null; ID.NUMBER_OF_ELEMENTS := 0; ID.CURRENT_INDEX := 0; end INITIALIZE; --======================================================================= -- Return elements from the list --======================================================================= function FIRST_ELEMENT (ID : in LIST_ID) return ELEMENT_OBJECT is --=========================== PDL ============================== --|ABSTRACT: --| FIRST_ELEMENT returns the value (content) of the first --| element in the linked list. --|DESIGN DESCRIPTION: --| If the list is empty (IS_EMPTY), raise LIST_IS_EMPTY --| Return the first element of the list --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; return ID.FIRST.CONTENT; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end FIRST_ELEMENT; function LAST_ELEMENT (ID : in LIST_ID) return ELEMENT_OBJECT is --=========================== PDL ============================== --|ABSTRACT: --| LAST_ELEMENT returns the value (content) of the last --| element in the linked list. --|DESIGN DESCRIPTION: --| If the list is empty (IS_EMPTY), raise LIST_IS_EMPTY --| Return the last element of the list --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; return ID.LAST.CONTENT; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end LAST_ELEMENT; function CURRENT_ELEMENT (ID : in LIST_ID) return ELEMENT_OBJECT is --=========================== PDL ============================== --|ABSTRACT: --| CURRENT_ELEMENT returns the value (content) of the current --| element in the linked list. --|DESIGN DESCRIPTION: --| If the list is empty (IS_EMPTY), raise LIST_IS_EMPTY --| Return the current element of the list --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; return ID.CURRENT.CONTENT; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end CURRENT_ELEMENT; --======================================================================= -- Position the current element in the list --======================================================================= procedure GOTO_FIRST (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| GOTO_FIRST sets the current element to be the first --| element in the linked list. --|DESIGN DESCRIPTION: --| Set CURRENT to FIRST --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; ID.CURRENT := ID.FIRST; ID.CURRENT_INDEX := 1; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end GOTO_FIRST; procedure GOTO_LAST (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| GOTO_LAST sets the current element to be the last --| element in the linked list. --|DESIGN DESCRIPTION: --| Set CURRENT to LAST --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; ID.CURRENT := ID.LAST; ID.CURRENT_INDEX := ID.NUMBER_OF_ELEMENTS; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end GOTO_LAST; procedure GOTO_ELEMENT (ID : in out LIST_ID; INDEX : in ELEMENT_POSITION) is --=========================== PDL ============================== --|ABSTRACT: --| GOTO sets the current element to be the Nth --| element in the linked list. --|DESIGN DESCRIPTION: --| If list IS_EMPTY, raise LIST_IS_EMPTY --| If INDEX > NUMBER_OF_ELEMENTS then raise INVALID_INDEX --| If INDEX < 1 then raise INVALID_INDEX --| Set CURRENT to point to the proper element --| Set CURRENT_INDEX to INDEX --============================================================== ROVER : ELEMENT_POINTER; begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; if INDEX > ID.NUMBER_OF_ELEMENTS then raise INVALID_INDEX; end if; if INDEX < 1 then raise INVALID_INDEX; end if; ROVER := ID.FIRST; if INDEX > 1 then for I in 1 .. INDEX - 1 loop ROVER := ROVER.NEXT; end loop; end if; ID.CURRENT := ROVER; ID.CURRENT_INDEX := INDEX; exception when LIST_IS_EMPTY | INVALID_INDEX => raise ; when others => raise UNEXPECTED_ERROR; end GOTO_ELEMENT; --======================================================================= -- Return the indices of the current and last elements --======================================================================= function CURRENT_INDEX (ID : in LIST_ID) return ELEMENT_POSITION is --=========================== PDL ============================== --|ABSTRACT: --| CURRENT_INDEX returns the index number of the current --| element in the linked list. --|DESIGN DESCRIPTION: --| If list IS_EMPTY, raise LIST_IS_EMPTY --| Return CURRENT_INDEX --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; return ID.CURRENT_INDEX; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end CURRENT_INDEX; function LAST_INDEX (ID : in LIST_ID) return ELEMENT_POSITION is --=========================== PDL ============================== --|ABSTRACT: --| LAST_INDEX returns the index number of the last --| element in the linked list. --|DESIGN DESCRIPTION: --| If list IS_EMPTY, raise LIST_IS_EMPTY --| Return NUMBER_OF_ELEMENTS --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; return ID.NUMBER_OF_ELEMENTS; exception when LIST_IS_EMPTY => raise ; when others => raise UNEXPECTED_ERROR; end LAST_INDEX; --======================================================================= -- Move through the list --======================================================================= procedure ADVANCE (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| ADVANCE sets the current element to be the next element --| if possible. --|DESIGN DESCRIPTION: --| If list IS_EMPTY, raise LIST_IS_EMPTY --| If at end of list (IS_END), raise ADVANCE_PAST_END_OF_LIST --| Set CURRENT.PREVIOUS to CURRENT --| Set CURRENT to CURRENT.NEXT --| Increment CURRENT_INDEX --|NOTE: --| ADVANCE will raise the ADVANCE_PAST_END_OF_LIST exception --| if we are already at the end of the list and try to --| advance from there. ADVANCE will not raise any exception --| if we were sitting on the last element and advanced to --| the end_of_list state. Hence, to use ADVANCE in coding, --| a recommended algorithm is: --| loop --| advance(mylist); --| exit when is_end(mylist); --| null; -- do what you wish with the next element --| end loop; --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; if IS_END (ID) then raise ADVANCE_PAST_END_OF_LIST; end if; ID.CURRENT.PREVIOUS := ID.CURRENT; ID.CURRENT := ID.CURRENT.NEXT; ID.CURRENT_INDEX := ID.CURRENT_INDEX + 1; exception when LIST_IS_EMPTY | ADVANCE_PAST_END_OF_LIST => raise ; when others => raise UNEXPECTED_ERROR; end ADVANCE; procedure BACKUP (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| BACKUP sets the current element to be the previous element --| if possible. --|DESIGN DESCRIPTION: --| If list IS_EMPTY, raise LIST_IS_EMPTY --| If at front of list (IS_FIRST), raise --| BACKUP_BEFORE_BEGINNING_OF_LIST --| Set CURRENT.PREVIOUS to CURRENT.PREVIOUS.PREVIOUS --| Set CURRENT.NEXT to CURRENT --| Set CURRENT to CURRENT.PREVIOUS --| Decrement CURRENT_INDEX --|NOTE: --| BACKUP will raise the BACKUP_BEFORE_BEGINNING_OF_LIST --| exception if we are already at the start of the list and try --| to backup from there. Hence, to use BACKUP in coding, --| a recommended algorithm is: --| loop --| null; -- do what you wish with the next element --| exit when is_first(mylist); --| backup(mylist); --| end loop; --============================================================== begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; if IS_FIRST (ID) then raise BACKUP_BEFORE_BEGINNING_OF_LIST; end if; ID.CURRENT.PREVIOUS := ID.CURRENT.PREVIOUS.PREVIOUS; ID.CURRENT.NEXT := ID.CURRENT; ID.CURRENT := ID.CURRENT.PREVIOUS; ID.CURRENT_INDEX := ID.CURRENT_INDEX - 1; exception when LIST_IS_EMPTY | BACKUP_BEFORE_BEGINNING_OF_LIST => raise ; when others => raise UNEXPECTED_ERROR; end BACKUP; --======================================================================= -- Test the state of the list and the current element --======================================================================= function IS_EMPTY (ID : in LIST_ID) return BOOLEAN is --=========================== PDL ============================== --|ABSTRACT: --| IS_EMPTY returns TRUE if the list is empty; FALSE otherwise. --|DESIGN DESCRIPTION: --| If FIRST is NULL, return TRUE, else return FALSE --============================================================== begin return ID.FIRST = null; end IS_EMPTY; function IS_END (ID : in LIST_ID) return BOOLEAN is --=========================== PDL ============================== --|ABSTRACT: --| IS_END returns TRUE if we are past the last element of the --| list; FALSE otherwise. --|DESIGN DESCRIPTION: --| If CURRENT is NULL, return TRUE, else return FALSE --============================================================== begin return ID.CURRENT = null; end IS_END; function IS_FIRST (ID : in LIST_ID) return BOOLEAN is --=========================== PDL ============================== --|ABSTRACT: --| IS_FIRST returns TRUE if we are the first element of the --| list; FALSE otherwise. --|DESIGN DESCRIPTION: --| If CURRENT_INDEX is 1, return TRUE, else return FALSE --============================================================== begin return ID.CURRENT_INDEX = 1; end IS_FIRST; --======================================================================= -- Add elements to the list --======================================================================= procedure START_LIST (ID : in out LIST_ID; ELEMENT : ELEMENT_OBJECT) is --=========================== PDL ============================== --|ABSTRACT: --| START_LIST creates a new list with 1 element. --|DESIGN DESCRIPTION: --| Create NEW_ELEMENT (may raise DYNAMIC_MEMORY_ALLOCATION_PROBLEM) --| Set FIRST to NEW_ELEMENT --| Set LAST to NEW_ELEMENT --| Set CURRENT to NEW_ELEMENT --| Set NUMBER_OF_ELEMENTS to 1 --| Set CURRENT_INDEX to 1 --============================================================== NEW_ELEMENT : ELEMENT_POINTER; begin ALLOCATE (ID, ELEMENT, NEW_ELEMENT); ID.FIRST := NEW_ELEMENT; ID.LAST := NEW_ELEMENT; ID.CURRENT := NEW_ELEMENT; ID.NUMBER_OF_ELEMENTS := 1; ID.CURRENT_INDEX := 1; end START_LIST; procedure APPEND_ELEMENT (ID : in out LIST_ID; ELEMENT : ELEMENT_OBJECT) is --=========================== PDL ============================== --|ABSTRACT: --| APPEND_ELEMENT appends an element after the current --| element in the linked list. This new element is set --| to be the current element. --|DESIGN DESCRIPTION: --| If list IS_EMPTY --| Call START_LIST --| Else --| Create NEW_ELEMENT (may raise --| DYNAMIC_MEMORY_ALLOCATION_PROBLEM) --| If at end of list (CURRENT = LAST or IS_END) --| Set NEW_ELEMENT.PREVIOUS to LAST (NEW_ELEMENT.NEXT is --| already NULL) --| Set LAST.NEXT to NEW_ELEMENT --| Set LAST to NEW_ELEMENT --| Set CURRENT_INDEX to NUMBER_OF_ELEMENTS + 1 --| Else --| Set NEW_ELEMENT.NEXT to CURRENT.NEXT --| Set NEW_ELEMENT.PREVIOUS to CURRENT --| Set CURRENT.NEXT.PREVIOUS to NEW_ELEMENT --| Set CURRENT.NEXT to NEW_ELEMENT --| Increment CURRENT_INDEX --| End if --| Set CURRENT to NEW_ELEMENT --| Increment NUMBER_OF_ELEMENTS --| End if --============================================================== NEW_ELEMENT : ELEMENT_POINTER; begin if IS_EMPTY (ID) then START_LIST (ID, ELEMENT); else ALLOCATE (ID, ELEMENT, NEW_ELEMENT); if ID.CURRENT = ID.LAST or IS_END (ID) then NEW_ELEMENT.PREVIOUS := ID.LAST; ID.LAST.NEXT := NEW_ELEMENT; ID.LAST := NEW_ELEMENT; ID.CURRENT_INDEX := ID.NUMBER_OF_ELEMENTS + 1; else NEW_ELEMENT.NEXT := ID.CURRENT.NEXT; NEW_ELEMENT.PREVIOUS := ID.CURRENT; ID.CURRENT.NEXT.PREVIOUS := NEW_ELEMENT; ID.CURRENT.NEXT := NEW_ELEMENT; ID.CURRENT_INDEX := ID.CURRENT_INDEX + 1; end if; ID.CURRENT := NEW_ELEMENT; ID.NUMBER_OF_ELEMENTS := ID.NUMBER_OF_ELEMENTS + 1; end if; exception when DYNAMIC_MEMORY_ALLOCATION_PROBLEM => raise ; when others => raise UNEXPECTED_ERROR; end APPEND_ELEMENT; procedure INSERT_ELEMENT (ID : in out LIST_ID; ELEMENT : ELEMENT_OBJECT) is --=========================== PDL ============================== --|ABSTRACT: --| INSERT_ELEMENT inserts an element before the current --| element in the linked list. --|DESIGN DESCRIPTION: --| If list IS_EMPTY --| Call START_LIST --| Else --| Create NEW_ELEMENT (may raise --| DYNAMIC_MEMORY_ALLOCATION_PROBLEM) --| If at front of list (IS_FIRST) --| Set NEW_ELEMENT.NEXT to FIRST --| Set FIRST.PREVIOUS to NEW_ELEMENT --| Set FIRST to NEW_ELEMENT --| ElsIf at end of list (IS_END) --| Set NEW_ELEMENT.PREVIOUS to LAST (NEW_ELEMENT.NEXT is --| already NULL) --| Set LAST.NEXT to NEW_ELEMENT --| Set LAST to NEW_ELEMENT --| Else --| Set NEW_ELEMENT.NEXT to CURRENT --| Set NEW_ELEMENT.PREVIOUS to CURRENT.PREVIOUS --| Set CURRENT.PREVIOUS.NEXT to NEW_ELEMENT --| Set CURRENT.PREVIOUS to NEW_ELEMENT --| End if --| Increment CURRENT_INDEX --| Increment NUMBER_OF_ELEMENTS --| End if --============================================================== NEW_ELEMENT : ELEMENT_POINTER; begin if IS_EMPTY (ID) then START_LIST (ID, ELEMENT); else ALLOCATE (ID, ELEMENT, NEW_ELEMENT); if IS_FIRST (ID) then NEW_ELEMENT.NEXT := ID.FIRST; ID.FIRST.PREVIOUS := NEW_ELEMENT; ID.FIRST := NEW_ELEMENT; elsif IS_END (ID) then NEW_ELEMENT.PREVIOUS := ID.LAST; ID.LAST.NEXT := NEW_ELEMENT; ID.LAST := NEW_ELEMENT; else NEW_ELEMENT.NEXT := ID.CURRENT; NEW_ELEMENT.PREVIOUS := ID.CURRENT.PREVIOUS; ID.CURRENT.PREVIOUS.NEXT := NEW_ELEMENT; ID.CURRENT.PREVIOUS := NEW_ELEMENT; end if; ID.CURRENT_INDEX := ID.CURRENT_INDEX + 1; ID.NUMBER_OF_ELEMENTS := ID.NUMBER_OF_ELEMENTS + 1; end if; exception when DYNAMIC_MEMORY_ALLOCATION_PROBLEM => raise ; when others => raise UNEXPECTED_ERROR; end INSERT_ELEMENT; --======================================================================= -- Delete elements from the list --======================================================================= procedure DELETE_ELEMENT (ID : in out LIST_ID) is --=========================== PDL ============================== --|ABSTRACT: --| DELETE_ELEMENT deletes the current element in the linked --| list. The next element is made the current element. --|DESIGN DESCRIPTION: --| If list IS_EMPTY raise LIST_IS_EMPTY --| If list IS_END raise ADVANCE_PAST_END_OF_LIST --| If CURRENT is FIRST --| Set FIRST to CURRENT.NEXT --| Else --| Set NEXT of CURRENT.PREVIOUS to CURRENT.NEXT --| End if --| If CURRENT is LAST --| Set LAST to CURRENT.PREVIOUS --| Free up CURRENT --| Set CURRENT to NULL --| Else --| Set PREVIOUS of CURRENT.NEXT to CURRENT.PREVIOUS --| Free up CURRENT --| Set CURRENT to CURRENT.NEXT --| End if --| Decrement NUMBER_OF_ELEMENTS --============================================================== SAVE : ELEMENT_POINTER; begin if IS_EMPTY (ID) then raise LIST_IS_EMPTY; end if; if IS_END (ID) then raise ADVANCE_PAST_END_OF_LIST; end if; if ID.CURRENT = ID.FIRST then ID.FIRST := ID.CURRENT.NEXT; else ID.CURRENT.PREVIOUS.NEXT := ID.CURRENT.NEXT; end if; if ID.CURRENT = ID.LAST then ID.LAST := ID.CURRENT.PREVIOUS; ADD_TO_FREE (ID, ID.CURRENT); ID.CURRENT := null; else ID.CURRENT.NEXT.PREVIOUS := ID.CURRENT.PREVIOUS; SAVE := ID.CURRENT.NEXT; ADD_TO_FREE (ID, ID.CURRENT); ID.CURRENT := SAVE; end if; ID.NUMBER_OF_ELEMENTS := ID.NUMBER_OF_ELEMENTS - 1; exception when LIST_IS_EMPTY | ADVANCE_PAST_END_OF_LIST => raise ; when others => raise UNEXPECTED_ERROR; end DELETE_ELEMENT; end DOUBLY_LINKED_LIST; --:::::::::: --dyn.bdy --:::::::::: package body DYN is procedure CLEAR(DSTR: in out DYN_STRING) is begin DSTR.SIZE := 0; end CLEAR; function D_STRING(CHAR: CHARACTER) return DYN_STRING is DS : DYN_STRING; begin DS.SIZE := 1; DS.DATA(1) := CHAR; return DS; end D_STRING; function D_STRING(STR : STRING ) return DYN_STRING is DS : DYN_STRING; begin DS.SIZE := STR'LENGTH; DS.DATA(1..DS.SIZE) := STR; return DS; end D_STRING; function CHAR(DSTR : DYN_STRING; POSIT : POSITIVE := 1) return CHARACTER is begin if POSIT > DSTR.SIZE then raise STRING_TOO_SHORT; else return DSTR.DATA(POSIT); end if; end CHAR; function STR (DSTR: DYN_STRING) return STRING is begin return DSTR.DATA(1..DSTR.SIZE); end STR; function LENGTH(DSTR: DYN_STRING) return NATURAL is begin return DSTR.SIZE; end LENGTH; begin --(DYN) null; exception when others => raise; end DYN;